source: trunk/source/lib/ffi-darwinx8632.lisp @ 11357

Last change on this file since 11357 was 11357, checked in by rme, 13 years ago

Try to improve handling of small structs returned by value a little bit
more.

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