source: trunk/source/lib/ffi-win32.lisp @ 11188

Last change on this file since 11188 was 11188, checked in by gb, 12 years ago

Return an 8th value from the GENERATE-CALLBACK-BINDINGS hook, indicating
the number of declared argument bytes that would be passed on the stack.

File size: 7.5 KB
Line 
1(in-package "CCL")
2
3;;; Some small structures are returned in EAX and EDX.  Otherwise,
4;;; return values are placed at the address specified by the caller.
5(defun win32::record-type-returns-structure-as-first-arg (rtype)
6  (when (and rtype
7             (not (typep rtype 'unsigned-byte))
8             (not (member rtype *foreign-representation-type-keywords*
9                          :test #'eq)))
10    (let* ((ftype (if (typep rtype 'foreign-type)
11                    rtype
12                    (parse-foreign-type rtype)))
13           (nbits (ensure-foreign-type-bits ftype)))
14      (not (member nbits '(8 16 32 64))))))
15
16(defun win32::struct-from-regbuf-values (r rtype regbuf)
17  (ecase (ensure-foreign-type-bits rtype)
18    (8 `(setf (%get-unsigned-byte ,r 0) (%get-unsigned-byte ,regbuf 0)))
19    (16 `(setf (%get-unsigned-word ,r 0) (%get-unsigned-word ,regbuf 0)))
20    (32 `(setf (%get-unsigned-long ,r 0) (%get-unsigned-long ,regbuf 0)))
21    (64 `(setf (%%get-unsigned-longlong ,r 0)
22               (%%get-unsigned-longlong ,regbuf 0)))))
23
24;;; All arguments are passed on the stack.
25;;;
26;;; (We don't support the __m64, __m128, __m128d, and __m128i types.)
27
28(defun win32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
29  (let* ((result-type-spec (or (car (last args)) :void))
30         (regbuf nil)
31         (result-temp nil)
32         (result-form nil)
33         (struct-result-type nil))
34    (multiple-value-bind (result-type error)
35        (ignore-errors (parse-foreign-type result-type-spec))
36      (if error
37        (setq result-type-spec :void result-type *void-foreign-type*)
38        (setq args (butlast args)))
39      (collect ((argforms))
40        (when (eq (car args) :monitor-exception-ports)
41          (argforms (pop args)))
42        (when (typep result-type 'foreign-record-type)
43          (setq result-form (pop args)
44                struct-result-type result-type
45                result-type *void-foreign-type*
46                result-type-spec :void)
47          (if (win32::record-type-returns-structure-as-first-arg result-type)
48            (progn
49              (argforms :address)
50              (argforms result-form))
51            (progn
52              (setq regbuf (gensym)
53                    result-temp (gensym))
54              (argforms :registers)
55              (argforms regbuf))))
56        (unless (evenp (length args))
57          (error "~s should be an even-length list of alternating foreign types and values" args))
58        (do* ((args args (cddr args)))
59             ((null args))
60          (let* ((arg-type-spec (car args))
61                 (arg-value-form (cadr args)))
62            (if (or (member arg-type-spec *foreign-representation-type-keywords*
63                            :test #'eq)
64                    (typep arg-type-spec 'unsigned-byte))
65              (progn
66                (argforms arg-type-spec)
67                (argforms arg-value-form))
68              (let* ((ftype (parse-foreign-type arg-type-spec))
69                     (bits (ensure-foreign-type-bits ftype)))
70                    (when (and (typep ftype 'foreign-record-type)
71                             (eq (foreign-record-type-kind ftype) :transparent-union))
72                      (ensure-foreign-type-bits ftype)
73                      (setq ftype (foreign-record-field-type
74                                   (car (foreign-record-type-fields ftype)))
75                            arg-type-spec (foreign-type-to-representation-type ftype)
76                            bits (ensure-foreign-type-bits ftype)))
77                    (if (and (typep ftype 'foreign-record-type)
78                             (<= bits 32))
79                      (argforms (ceiling bits 32))
80                      (argforms (foreign-type-to-representation-type ftype)))
81                (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))
82          (argforms (foreign-type-to-representation-type result-type))
83          (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
84            (if regbuf
85              `(let* ((,result-temp (%null-ptr)))
86                 (declare (dynamic-extent ,result-temp)
87                          (type macptr ,result-temp))
88                 (%setf-macptr ,result-temp ,result-form)
89                 (%stack-block ((,regbuf 8))
90                   ,call
91                   ,(win32::struct-from-regbuf-values result-temp struct-result-type regbuf)))
92              call))))))
93
94;;; Return 8 values:
95;;; A list of RLET bindings
96;;; A list of LET* bindings
97;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
98;;; A list of initializaton forms for (some) structure args
99;;; A FOREIGN-TYPE representing the "actual" return type.
100;;; A form which can be used to initialize FP-ARGS-PTR, relative
101;;;  to STACK-PTR.  (This is unused on linuxppc32.)
102;;; The byte offset of the foreign return address, relative to STACK-PTR
103;;; The number of argument bytes pushed on the stack by the caller, or NIL
104;;; if this can't be determined.
105(defun win32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
106  (declare (ignore fp-args-ptr))
107  (collect ((lets)
108            (rlets)
109            (inits)
110            (dynamic-extent-names))
111    (let* ((rtype (parse-foreign-type result-spec)))
112      (when (typep rtype 'foreign-record-type)
113        (if (win32::record-type-returns-structure-as-first-arg rtype)
114          (setq argvars (cons struct-result-name argvars)
115                argspecs (cons :address argspecs)
116                rtype *void-foreign-type*)
117          (rlets (list struct-result-name (foreign-record-type-name rtype)))))
118      (do* ((argvars argvars (cdr argvars))
119            (argspecs argspecs (cdr argspecs))
120            (offset 8 (incf offset 4)))
121           ((null argvars)
122            (values (rlets) (lets) (dynamic-extent-names) (inits) rtype nil 4 (- offset 8)))
123        (let* ((name (car argvars))
124               (spec (car argspecs))
125               (argtype (parse-foreign-type spec))
126               (bits (require-foreign-type-bits argtype))
127               (double nil))
128          (if (typep argtype 'foreign-record-type)
129            (progn
130              (format t "~& arg is some foreign type"))
131            (lets (list name
132                        `(,
133                          (ecase (foreign-type-to-representation-type argtype)
134                            (:single-float '%get-single-float)
135                            (:double-float (setq double t) '%get-double-float)
136                            (:signed-doubleword (setq double t)
137                                                '%%get-signed-longlong)
138                            (:signed-fullword '%get-signed-long)
139                            (:signed-halfword '%get-signed-word)
140                            (:signed-byte '%get-signed-byte)
141                            (:unsigned-doubleword (setq double t)
142                                                  '%%get-unsigned-longlong)
143                            (:unsigned-fullword '%get-unsigned-long)
144                            (:unsigned-halfword '%get-unsigned-word)
145                            (:unsigned-byte '%get-unsigned-byte)
146                            (:address '%get-ptr))
147                          ,stack-ptr
148                          ,offset))))
149          (when double (incf offset 4)))))))
150
151(defun win32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
152  (declare (ignore fp-args-ptr))
153  (format t "~&in generate-callback-return-value")
154  (unless (eq return-type *void-foreign-type*)
155    (if (typep return-type 'foreign-record-type)
156      ;; Would have been mapped to :VOID unless record-type was <= 64 bits
157      (format t "~&need to return structure ~s by value" return-type)
158      (let* ((return-type-keyword (foreign-type-to-representation-type return-type)))
159        (ccl::collect ((forms))
160          (forms 'progn)
161          (case return-type-keyword
162            (:single-float
163             (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 1)))
164            (:double-float
165             (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 2))))
166          (forms
167           `(setf (,
168                   (case return-type-keyword
169                     (:address '%get-ptr)
170                     (:signed-doubleword '%%get-signed-longlong)
171                     (:unsigned-doubleword '%%get-unsigned-longlong)
172                     (:double-float '%get-double-float)
173                     (:single-float '%get-single-float)
174                     (:unsigned-fullword '%get-unsigned-long)
175                     (t '%get-signed-long)
176                     ) ,stack-ptr -8) ,result))
177          (forms))))))
178
Note: See TracBrowser for help on using the repository browser.