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

Last change on this file since 11549 was 11549, checked in by rme, 12 years ago

Merge fixes from ffi-darwinx8632 so that structure arg passing works.

We always return structures as a hidden first arg on Linux/x8632, so
update x86-linux32::record-type-returns-structure-as-first-arg to
return t always. Also update expand-ff-call and
generate-callback-return-value accordingly.

File size: 5.9 KB
Line 
1(in-package "CCL")
2
3;; Always use the "hidden first arg" convention on linuxx8632
4(defun x86-linux32::record-type-returns-structure-as-first-arg (rtype)
5  (declare (ignore rtype))
6  t)
7
8;;; All arguments are passed on the stack.
9;;;
10;;; (We don't support the __m64, __m128, __m128d, and __m128i types.)
11
12(defun x86-linux32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
13  (let* ((result-type-spec (or (car (last args)) :void))
14         (result-form nil))
15    (multiple-value-bind (result-type error)
16        (ignore-errors (parse-foreign-type result-type-spec))
17      (if error
18        (setq result-type-spec :void result-type *void-foreign-type*)
19        (setq args (butlast args)))
20      (collect ((argforms))
21        (when (typep result-type 'foreign-record-type)
22          (setq result-form (pop args)
23                result-type *void-foreign-type*
24                result-type-spec :void)
25          (argforms :address)
26          (argforms result-form))
27        (unless (evenp (length args))
28          (error "~s should be an even-length list of alternating foreign types and values" args))
29        (do* ((args args (cddr args)))
30             ((null args))
31          (let* ((arg-type-spec (car args))
32                 (arg-value-form (cadr args)))
33            (if (or (member arg-type-spec *foreign-representation-type-keywords*
34                            :test #'eq)
35                    (typep arg-type-spec 'unsigned-byte))
36              (progn
37                (argforms arg-type-spec)
38                (argforms arg-value-form))
39              (let* ((ftype (parse-foreign-type arg-type-spec))
40                     (bits (ensure-foreign-type-bits ftype)))
41                    (when (and (typep ftype 'foreign-record-type)
42                             (eq (foreign-record-type-kind ftype) :transparent-union))
43                      (ensure-foreign-type-bits ftype)
44                      (setq ftype (foreign-record-field-type
45                                   (car (foreign-record-type-fields ftype)))
46                            arg-type-spec (foreign-type-to-representation-type ftype)
47                            bits (ensure-foreign-type-bits ftype)))
48                    (if (typep ftype 'foreign-record-type)
49                      (argforms (ceiling bits 32))
50                      (argforms (foreign-type-to-representation-type ftype)))
51                (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))
52          (argforms (foreign-type-to-representation-type result-type))
53          (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
54            call)))))
55
56;;; Return 7 values:
57;;; A list of RLET bindings
58;;; A list of LET* bindings
59;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
60;;; A list of initializaton forms for (some) structure args (not used on x8632)
61;;; A FOREIGN-TYPE representing the "actual" return type.
62;;; A form which can be used to initialize FP-ARGS-PTR, relative
63;;;  to STACK-PTR.  (This is unused on linuxppc32.)
64;;; The byte offset of the foreign return address, relative to STACK-PTR
65
66(defun x86-linux32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
67  (declare (ignore fp-args-ptr))
68  (collect ((lets)
69            (rlets)
70            (dynamic-extent-names))
71    (let* ((rtype (parse-foreign-type result-spec)))
72      (when (typep rtype 'foreign-record-type)
73        (if (x86-linux32::record-type-returns-structure-as-first-arg rtype)
74          (setq argvars (cons struct-result-name argvars)
75                argspecs (cons :address argspecs)
76                rtype *void-foreign-type*)
77          (rlets (list struct-result-name (foreign-record-type-name rtype)))))
78      (do* ((argvars argvars (cdr argvars))
79            (argspecs argspecs (cdr argspecs))
80            (offset 8))
81           ((null argvars)
82            (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 4))
83        (let* ((name (car argvars))
84               (spec (car argspecs))
85               (argtype (parse-foreign-type spec))
86               (bits (require-foreign-type-bits argtype))
87               (double nil))
88          (if (typep argtype 'foreign-record-type)
89            (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 offset
90                                                           (incf offset (* 4 (ceiling bits 32)))))))
91            (progn
92              (lets (list name
93                          `(,
94                            (ecase (foreign-type-to-representation-type argtype)
95                              (:single-float '%get-single-float)
96                              (:double-float (setq double t) '%get-double-float)
97                              (:signed-doubleword (setq double t)
98                                                  '%%get-signed-longlong)
99                              (:signed-fullword '%get-signed-long)
100                              (:signed-halfword '%get-signed-word)
101                              (:signed-byte '%get-signed-byte)
102                              (:unsigned-doubleword (setq double t)
103                                                    '%%get-unsigned-longlong)
104                              (:unsigned-fullword '%get-unsigned-long)
105                              (:unsigned-halfword '%get-unsigned-word)
106                              (:unsigned-byte '%get-unsigned-byte)
107                              (:address '%get-ptr))
108                            ,stack-ptr
109                            ,offset)))
110              (incf offset 4)
111              (when double (incf offset 4)))))))))
112
113(defun x86-linux32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
114  (declare (ignore fp-args-ptr struct-return-arg))
115  (unless (eq return-type *void-foreign-type*)
116    (if (typep return-type 'foreign-record-type)
117      ;; Should have been mapped to :VOID
118      (error "Shouldn't be trying to return a structure by value on linuxx8632")
119      (let* ((return-type-keyword (foreign-type-to-representation-type return-type)))
120        (collect ((forms))
121          (forms 'progn)
122          (case return-type-keyword
123            (:single-float
124             (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 1)))
125            (:double-float
126             (forms `(setf (%get-unsigned-byte ,stack-ptr -16) 2))))
127          (forms
128           `(setf (,
129                   (case return-type-keyword
130                     (:address '%get-ptr)
131                     (:signed-doubleword '%%get-signed-longlong)
132                     (:unsigned-doubleword '%%get-unsigned-longlong)
133                     (:double-float '%get-double-float)
134                     (:single-float '%get-single-float)
135                     (:unsigned-fullword '%get-unsigned-long)
136                     (t '%get-signed-long)
137                     ) ,stack-ptr -8) ,result))
138          (forms))))))
139
Note: See TracBrowser for help on using the repository browser.