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

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

Pass small (<= 32 bits) structures by value.

File size: 6.4 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(defun x86-darwin32::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 x86-darwin32::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 (x86-darwin32::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                (if (and (typep ftype 'foreign-record-type)
71                         (<= bits 32))
72                  (argforms (ceiling bits 32))
73                  (argforms (foreign-type-to-representation-type ftype)))
74                (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))
75          (argforms (foreign-type-to-representation-type result-type))
76          (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
77            (if regbuf
78              `(let* ((,result-temp (%null-ptr)))
79                 (declare (dynamic-extent ,result-temp)
80                          (type macptr ,result-temp))
81                 (%setf-macptr ,result-temp ,result-form)
82                 (%stack-block ((,regbuf 8))
83                   ,call
84                   ,(x86-darwin32::struct-from-regbuf-values result-temp struct-result-type regbuf)))
85              call))))))
86
87;;; Return 7 values:
88;;; A list of RLET bindings
89;;; A list of LET* bindings
90;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
91;;; A list of initializaton forms for (some) structure args
92;;; A FOREIGN-TYPE representing the "actual" return type.
93;;; A form which can be used to initialize FP-ARGS-PTR, relative
94;;;  to STACK-PTR.  (This is unused on linuxppc32.)
95;;; The byte offset of the foreign return address, relative to STACK-PTR
96
97(defun x86-darwin32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
98  (declare (ignore fp-args-ptr))
99  (collect ((lets)
100            (rlets)
101            (inits)
102            (dynamic-extent-names))
103    (let* ((rtype (parse-foreign-type result-spec)))
104      (when (typep rtype 'foreign-record-type)
105        (if (x86-darwin32::record-type-returns-structure-as-first-arg rtype)
106          (setq argvars (cons struct-result-name argvars)
107                argspecs (cons :address argspecs)
108                rtype *void-foreign-type*)
109          (rlets (list struct-result-name (foreign-record-type-name rtype)))))
110      (do* ((argvars argvars (cdr argvars))
111            (argspecs argspecs (cdr argspecs))
112            (offset 8 (incf offset 4)))
113           ((null argvars)
114            (values (rlets) (lets) (dynamic-extent-names) (inits) rtype nil 4))
115        (let* ((name (car argvars))
116               (spec (car argspecs))
117               (argtype (parse-foreign-type spec))
118               (bits (require-foreign-type-bits argtype))
119               (double nil))
120          (if (typep argtype 'foreign-record-type)
121            (progn
122              (format t "~& arg is some foreign type"))
123            (lets (list name
124                        `(,
125                          (ecase (foreign-type-to-representation-type argtype)
126                            (:single-float '%get-single-float)
127                            (:double-float (setq double t) '%get-double-float)
128                            (:signed-doubleword (setq double t)
129                                                '%%get-signed-longlong)
130                            (:signed-fullword '%get-signed-long)
131                            (:signed-halfword '%get-signed-word)
132                            (:signed-byte '%get-signed-byte)
133                            (:unsigned-doubleword (setq double t)
134                                                  '%%get-unsigned-longlong)
135                            (:unsigned-fullword '%get-unsigned-long)
136                            (:unsigned-halfword '%get-unsigned-word)
137                            (:unsigned-byte '%get-unsigned-byte)
138                            (:address '%get-ptr))
139                          ,stack-ptr
140                          ,offset))))
141          (when double (incf offset 4)))))))
142
143(defun x86-darwin32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
144  (declare (ignore fp-args-ptr))
145  (format t "~&in generate-callback-return-value")
146  (unless (eq return-type *void-foreign-type*)
147    (if (typep return-type 'foreign-record-type)
148      ;; Would have been mapped to :VOID unless record-type was <= 64 bits
149      (format t "~&need to return structure ~s by value" return-type)
150      (let* ((return-type-keyword (foreign-type-to-representation-type return-type)))
151        `(setf (,
152                (case return-type-keyword
153                  (:address '%get-ptr)
154                  (:signed-doubleword '%%get-signed-longlong)
155                  (:unsigned-doubleword '%%get-unsigned-longlong)
156                  (:double-float '%get-double-float)
157                  (:single-float '%get-single-float)
158                  (:unsigned-fullword '%get-unsigned-long)
159                  (t '%get-signed-long)
160                  ) ,stack-ptr 8) ,result)))))
161
Note: See TracBrowser for help on using the repository browser.