source: branches/qres/ccl/lib/ffi-win64.lisp @ 14308

Last change on this file since 14308 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

  • Property svn:executable set to *
File size: 8.1 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2007-2009 Clozure Associates and contributors
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19;;; Win64:
20;;; Structures are never actually passed by value; the caller
21;;; instead passes a pointer to the structure or a copy of it.
22;;;
23(defun win64::record-type-returns-structure-as-first-arg (rtype)
24  (when (and rtype
25             (not (typep rtype 'unsigned-byte))
26             (not (member rtype *foreign-representation-type-keywords*
27                          :test #'eq)))
28    (let* ((ftype (if (typep rtype 'foreign-type)
29                    rtype
30                    (parse-foreign-type rtype))))
31      (and (typep ftype 'foreign-record-type)
32           (> (ensure-foreign-type-bits ftype) 64)))))
33
34
35(defun win64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
36  (let* ((result-type-spec (or (car (last args)) :void))
37         (enclosing-form nil)
38         (result-form nil))
39    (multiple-value-bind (result-type error)
40        (ignore-errors (parse-foreign-type result-type-spec))
41      (if error
42        (setq result-type-spec :void result-type *void-foreign-type*)
43        (setq args (butlast args)))
44      (collect ((argforms))
45        (when (eq (car args) :monitor-exception-ports)
46          (argforms (pop args)))
47        (when (typep result-type 'foreign-record-type)
48          (setq result-form (pop args))
49          (if (win64::record-type-returns-structure-as-first-arg result-type)
50            (progn
51              (setq result-type *void-foreign-type*
52                    result-type-spec :void)
53              (argforms :address)
54              (argforms result-form))
55            ;; This only happens in the SVR4 ABI.
56            (progn
57              (setq result-type (parse-foreign-type :unsigned-doubleword)
58                    result-type-spec :unsigned-doubleword
59                    enclosing-form `(setf (%%get-unsigned-longlong ,result-form 0))))))
60        (unless (evenp (length args))
61          (error "~s should be an even-length list of alternating foreign types and values" args))       
62        (do* ((args args (cddr args)))
63             ((null args))
64          (let* ((arg-type-spec (car args))
65                 (arg-value-form (cadr args)))
66            (if (or (member arg-type-spec *foreign-representation-type-keywords*
67                           :test #'eq)
68                    (typep arg-type-spec 'unsigned-byte))
69              (progn
70                (argforms arg-type-spec)
71                (argforms arg-value-form))
72              (let* ((ftype (parse-foreign-type arg-type-spec)))
73                (if (typep ftype 'foreign-record-type)
74                  (progn
75                    (argforms :address)
76                    (argforms arg-value-form))
77                  (progn
78                    (argforms (foreign-type-to-representation-type ftype))
79                    (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))))
80        (argforms (foreign-type-to-representation-type result-type))
81        (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
82          (if enclosing-form
83            `(,@enclosing-form ,call)
84            call))))))
85
86;;; Return 7 values:
87;;; A list of RLET bindings
88;;; A list of LET* bindings
89;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
90;;; A list of initializaton forms for (some) structure args
91;;; A FOREIGN-TYPE representing the "actual" return type.
92;;; A form which can be used to initialize FP-ARGS-PTR, relative
93;;;  to STACK-PTR.
94;;; The byte offset of the foreign return address, relative to STACK-PTR
95(defun win64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
96  (declare (ignore fp-args-ptr))
97  (collect ((lets)
98            (rlets)
99            (inits))
100    (let* ((rtype (parse-foreign-type result-spec)))
101      (when (typep rtype 'foreign-record-type)
102        (if (win64::record-type-returns-structure-as-first-arg rtype)
103          (setq argvars (cons struct-result-name argvars)
104                argspecs (cons :address argspecs)
105                rtype :address)
106          (rlets (list struct-result-name (foreign-record-type-name rtype)))))
107      (do* ((argvars argvars (cdr argvars))
108            (argspecs argspecs (cdr argspecs))
109            (arg-num 0)
110            (gpr-arg-offset -8)
111            (fpr-arg-offset -40)
112            (memory-arg-offset 48)
113            (fp nil nil))
114           ((null argvars)
115            (values (rlets) (lets) nil (inits) rtype nil 8))
116        (flet ((next-gpr ()
117                 (if (<= (incf arg-num) 4)
118                   (prog1
119                       gpr-arg-offset
120                     (decf gpr-arg-offset 8)
121                     (decf fpr-arg-offset 8))
122                   (prog1
123                       memory-arg-offset
124                     (incf memory-arg-offset 8))))
125               (next-fpr ()
126                 (if (<= (incf arg-num) 4)
127                   (prog1
128                       fpr-arg-offset
129                     (decf fpr-arg-offset 8)
130                     (decf gpr-arg-offset 8))
131                   (prog1
132                       memory-arg-offset
133                     (incf memory-arg-offset 8)))))
134          (let* ((name (car argvars))
135                 (spec (car argspecs))
136                 (argtype (parse-foreign-type spec)))
137            (if (typep argtype 'foreign-record-type)
138              (setq argtype :address))
139            (let* ((access-form
140                    `(,
141                          (ecase (foreign-type-to-representation-type argtype)
142                            (:single-float (setq fp t) '%get-single-float)
143                            (:double-float (setq fp t) '%get-double-float)
144                            (:signed-doubleword  '%%get-signed-longlong)
145                            (:signed-fullword '%get-signed-long)
146                            (:signed-halfword '%get-signed-word)
147                            (:signed-byte '%get-signed-byte)
148                            (:unsigned-doubleword '%%get-unsigned-longlong)
149                            (:unsigned-fullword '%get-unsigned-long)
150                            (:unsigned-halfword '%get-unsigned-word)
151                            (:unsigned-byte '%get-unsigned-byte)
152                            (:address
153                             #+nil
154                             (dynamic-extent-names name)
155                             '%get-ptr))
156                          ,stack-ptr
157                          ,(if fp (next-fpr) (next-gpr)))))
158              (when name (lets (list name access-form))))))))))
159
160(defun win64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
161  (declare (ignore fp-args-ptr))
162  (unless (eq return-type *void-foreign-type*)
163    (when (typep return-type 'foreign-single-float-type)
164      (setq result `(float ,result 0.0d0)))   
165    (let* ((return-type-keyword
166            (if (typep return-type 'foreign-record-type)
167              (progn
168                (setq result `(%%get-unsigned-longlong ,struct-return-arg 0))
169                :unsigned-doubleword)
170              (foreign-type-to-representation-type return-type)))
171           (offset (case return-type-keyword
172                   ((:single-float :double-float)
173                    -24)
174                   (t -8))))
175      `(setf (,
176              (case return-type-keyword
177                (:address '%get-ptr)
178                (:signed-doubleword '%%get-signed-longlong)
179                (:unsigned-doubleword '%%get-unsigned-longlong)
180                ((:double-float :single-float) '%get-double-float)
181                (t '%get-long)) ,stack-ptr ,offset) ,result))))
182     
183                 
Note: See TracBrowser for help on using the repository browser.