source: trunk/source/lib/ffi-linuxx8632.lisp @ 10790

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

Return callback results differently (requires changes in .SPcallback
subprim.)

Assume that .SPcallback has reserved a few words on entry; store
results there, and set a flag in a word that's zeroed by .SPcallback
to indicate whether the result is a float that needs to be loaded
into the x87.

(Need to do similar things on Darwinx8632).

File size: 7.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-linux32::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-linux32::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-linux32::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-linux32::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                   ,(x86-linux32::struct-from-regbuf-values result-temp struct-result-type regbuf)))
92              call))))))
93
94;;; Return 7 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
104(defun x86-linux32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
105  (declare (ignore fp-args-ptr))
106  (collect ((lets)
107            (rlets)
108            (inits)
109            (dynamic-extent-names))
110    (let* ((rtype (parse-foreign-type result-spec)))
111      (when (typep rtype 'foreign-record-type)
112        (if (x86-linux32::record-type-returns-structure-as-first-arg rtype)
113          (setq argvars (cons struct-result-name argvars)
114                argspecs (cons :address argspecs)
115                rtype *void-foreign-type*)
116          (rlets (list struct-result-name (foreign-record-type-name rtype)))))
117      (do* ((argvars argvars (cdr argvars))
118            (argspecs argspecs (cdr argspecs))
119            (offset 8 (incf offset 4)))
120           ((null argvars)
121            (values (rlets) (lets) (dynamic-extent-names) (inits) rtype nil 4))
122        (let* ((name (car argvars))
123               (spec (car argspecs))
124               (argtype (parse-foreign-type spec))
125               (bits (require-foreign-type-bits argtype))
126               (double nil))
127          (if (typep argtype 'foreign-record-type)
128            (progn
129              (format t "~& arg is some foreign type"))
130            (lets (list name
131                        `(,
132                          (ecase (foreign-type-to-representation-type argtype)
133                            (:single-float '%get-single-float)
134                            (:double-float (setq double t) '%get-double-float)
135                            (:signed-doubleword (setq double t)
136                                                '%%get-signed-longlong)
137                            (:signed-fullword '%get-signed-long)
138                            (:signed-halfword '%get-signed-word)
139                            (:signed-byte '%get-signed-byte)
140                            (:unsigned-doubleword (setq double t)
141                                                  '%%get-unsigned-longlong)
142                            (:unsigned-fullword '%get-unsigned-long)
143                            (:unsigned-halfword '%get-unsigned-word)
144                            (:unsigned-byte '%get-unsigned-byte)
145                            (:address '%get-ptr))
146                          ,stack-ptr
147                          ,offset))))
148          (when double (incf offset 4)))))))
149
150(defun x86-linux32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
151  (declare (ignore fp-args-ptr))
152  (format t "~&in generate-callback-return-value")
153  (unless (eq return-type *void-foreign-type*)
154    (if (typep return-type 'foreign-record-type)
155      ;; Would have been mapped to :VOID unless record-type was <= 64 bits
156      (format t "~&need to return structure ~s by value" return-type)
157      (let* ((return-type-keyword (foreign-type-to-representation-type return-type)))
158        (ccl::collect ((forms))
159          (forms 'progn)
160          (case return-type-keyword
161            (:single-float
162             (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 1)))
163            (:double-float
164             (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 2))))
165          (forms
166           `(setf (,
167                   (case return-type-keyword
168                     (:address '%get-ptr)
169                     (:signed-doubleword '%%get-signed-longlong)
170                     (:unsigned-doubleword '%%get-unsigned-longlong)
171                     (:double-float '%get-double-float)
172                     (:single-float '%get-single-float)
173                     (:unsigned-fullword '%get-unsigned-long)
174                     (t '%get-signed-long)
175                     ) ,stack-ptr -8) ,result))
176          (forms))))))
177
Note: See TracBrowser for help on using the repository browser.