source: branches/qres/ccl/lib/ffi-darwinppc32.lisp @ 14172

Last change on this file since 14172 was 13070, checked in by gz, 10 years ago

r13066, r13067 from trunk: copyrights etc

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 12.9 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2007-2009 Clozure Associates and contributors
4;;;   This file is part of Clozure CL. 
5;;;
6;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with Clozure CL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19;;; If a record type has a single scalar field, return the type
20;;; of that field.
21(defun darwin32::record-type-has-single-scalar-field (record-type)
22  (when (eq (foreign-record-type-kind record-type) :struct)
23    (require-foreign-type-bits record-type)
24    (let* ((fields (foreign-record-type-fields record-type)))
25      (when (null (cdr fields))
26        (let* ((f0 (car fields))
27               (type (foreign-record-field-type f0)))
28          (typecase type
29            ((or foreign-record-type foreign-array-type) nil)
30            (otherwise type)))))))
31
32;;; If type denotes a foreign record type, return T if it would
33;;; be "returned" by passing it as the first argument to the callee.
34;;; On DarwinPPC32, this is true of all record types except for
35;;; those for which RECORD-TYPE-HAS-SINGLE-SCALAR-FIELD returns
36;;; true.
37(defun darwin32::record-type-returns-structure-as-first-arg (rtype)
38  (when (and rtype
39             (not (typep rtype 'unsigned-byte))
40             (not (member rtype *foreign-representation-type-keywords*
41                          :test #'eq)))
42    (let* ((ftype (if (typep rtype 'foreign-type)
43                    rtype
44                    (parse-foreign-type rtype))))
45      (and (typep ftype 'foreign-record-type)
46           (not (darwin32::record-type-has-single-scalar-field ftype))))))
47
48
49;;; Structures that contain a single scalar field are "returned"
50;;; as a value with that field's type.
51;;; Other structures are "returned" by passing a pointer to a structure
52;;; of the appropriate type as the first argument.
53;;; Structures that contain a single scalar field are passed by value
54;;; by passing the value of that field as a scalar.
55;;; Structures that contain more than one field are passed by value
56;;; as a sequence of N 32-bit words; %ff-call understands an unsigned
57;;; integer argument "type" specifier to denote this.
58
59(defun darwin32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
60  (let* ((result-type-spec (or (car (last args)) :void))
61         (enclosing-form nil))
62    (multiple-value-bind (result-type error)
63        (ignore-errors (parse-foreign-type result-type-spec))
64      (if error
65        (setq result-type-spec :void result-type *void-foreign-type*)
66        (setq args (butlast args)))
67      (collect ((argforms))
68        (when (eq (car args) :monitor-exception-ports)
69          (argforms (pop args)))
70        (when (typep result-type 'foreign-record-type)
71          (let* ((single-scalar (darwin32::record-type-has-single-scalar-field result-type))
72                 (result-form (pop args)))
73            (if single-scalar
74              (progn
75                (setq enclosing-form `(setf ,(%foreign-access-form result-form single-scalar 0 nil))
76                      result-type single-scalar
77                      result-type-spec (foreign-type-to-representation-type result-type)))
78                     
79              (progn
80                (argforms :address)
81                (argforms result-form)
82                (setq result-type *void-foreign-type*
83                      result-type-spec :void)))))
84        (unless (evenp (length args))
85          (error "~s should be an even-length list of alternating foreign types and values" args))
86        (do* ((args args (cddr args)))
87             ((null args))
88          (let* ((arg-type-spec (car args))
89                 (arg-value-form (cadr args)))
90            (if (or (member arg-type-spec *foreign-representation-type-keywords*
91                           :test #'eq)
92                    (typep arg-type-spec 'unsigned-byte))
93              (progn
94                (argforms arg-type-spec)
95                (argforms arg-value-form))
96              (let* ((ftype (parse-foreign-type arg-type-spec)))
97                (if (typep ftype 'foreign-record-type)
98                  (let* ((single-scalar (darwin32::record-type-has-single-scalar-field ftype)))
99                    (if single-scalar
100                      (progn
101                        (argforms (foreign-type-to-representation-type single-scalar))
102                        (argforms (%foreign-access-form arg-value-form single-scalar 0 nil)))
103                      (let* ((bits (ensure-foreign-type-bits ftype)))
104                        (argforms (ceiling bits 32))
105                        (argforms arg-value-form))))
106                  (progn
107                    (argforms (foreign-type-to-representation-type ftype))
108                    (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))))
109        (argforms (foreign-type-to-representation-type result-type))
110        (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
111          (if enclosing-form
112            `(,@enclosing-form ,call)
113            call))))))
114                 
115           
116           
117;;; Return 7 values:
118;;; A list of RLET bindings
119;;; A list of LET* bindings
120;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
121;;; A list of initializaton forms for (some) structure args
122;;; A FOREIGN-TYPE representing the "actual" return type.
123;;; A form which can be used to initialize FP-ARGS-PTR, relative
124;;;  to STACK-PTR.  (This is unused on linuxppc32.)
125;;; The byte offset of the foreign return address, relative to STACK-PTR
126
127(defun darwin32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
128  (collect ((lets)
129            (rlets)
130            (inits)
131            (dynamic-extent-names))
132    (let* ((rtype (parse-foreign-type result-spec))
133           (fp-regs-form nil))
134      (flet ((set-fp-regs-form ()
135               (unless fp-regs-form
136                 (setq fp-regs-form `(%get-ptr ,stack-ptr ,(- ppc32::c-frame.unused-1 ppc32::c-frame.param0))))))
137        (when (typep rtype 'foreign-record-type)
138          (if (darwin32::record-type-has-single-scalar-field rtype)
139            (rlets (list struct-result-name (foreign-record-type-name rtype)))
140            (setq argvars (cons struct-result-name argvars)
141                  argspecs (cons :address argspecs)
142                  rtype *void-foreign-type*)))
143        (when (typep rtype 'foreign-float-type)
144          (set-fp-regs-form))
145        (do* ((argvars argvars (cdr argvars))
146              (argspecs argspecs (cdr argspecs))
147              (fp-arg-num 0)
148              (offset 0 (+ offset delta))
149              (delta 4 4)
150              (bias 0 0)
151              (use-fp-args nil nil))
152             ((null argvars)
153              (values (rlets) (lets) (dynamic-extent-names) (inits) rtype fp-regs-form (- ppc32::c-frame.savelr ppc32::c-frame.param0)))
154          (flet ((next-scalar-arg (argtype)
155                   `(,(cond
156                       ((typep argtype 'foreign-single-float-type)
157                        (if (< (incf fp-arg-num) 14)
158                          (progn
159                            (setq use-fp-args t)
160                            '%get-single-float-from-double-ptr)
161                          (progn
162                            '%get-single-float)))
163                       ((typep argtype 'foreign-double-float-type)
164                        (setq delta 8)
165                        (if (< (incf fp-arg-num) 14)
166                          (setq use-fp-args t))
167                        '%get-double-float)
168                       ((and (typep argtype 'foreign-integer-type)
169                             (= (foreign-integer-type-bits argtype) 64)
170                             (foreign-integer-type-signed argtype))
171                        (setq delta 8)
172                        '%%get-signed-longlong)
173                       ((and (typep argtype 'foreign-integer-type)
174                             (= (foreign-integer-type-bits argtype) 64)
175                             (not (foreign-integer-type-signed argtype)))
176                        (setq delta 8)
177                        '%%get-unsigned-longlong)
178                       ((or (typep argtype 'foreign-pointer-type)
179                            (typep argtype 'foreign-array-type))
180                        '%get-ptr)
181                       (t
182                        (cond ((typep argtype 'foreign-integer-type)
183                               (let* ((bits (foreign-integer-type-bits argtype))
184                                      (signed (foreign-integer-type-signed argtype)))
185                                 (cond ((<= bits 8)
186                                        (setq bias 3)
187                                        (if signed
188                                          '%get-signed-byte
189                                          '%get-unsigned-byte))
190                                       ((<= bits 16)
191                                        (setq bias 2)
192                                        (if signed
193                                          '%get-signed-word 
194                                          '%get-unsigned-word))
195                                       ((<= bits 32)
196                                        (if signed
197                                          '%get-signed-long 
198                                          '%get-unsigned-long))
199                                       (t
200                                        (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
201                              (t
202                               (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
203                     ,(if use-fp-args fp-args-ptr stack-ptr)
204                     ,(if use-fp-args (* 8 (1- fp-arg-num))
205                          (+ offset bias)))))                   
206          (let* ((name (car argvars))
207                 (spec (car argspecs))
208                 (argtype (parse-foreign-type spec)))
209            (if (typep argtype 'foreign-record-type)
210              (let* ((type0 (darwin32::record-type-has-single-scalar-field argtype)))
211                (if type0
212                  (progn
213                    (when name (rlets (list name (foreign-record-type-name argtype))))
214                    (let* ((init `(setf ,(%foreign-access-form name type0 0 nil)
215                             ,(next-scalar-arg type0))))
216                      (when name (inits init))))
217                  (progn
218                    (setq delta (* (ceiling (foreign-record-type-bits argtype) 32) 4))
219                    (when name ; no side-efects hers     
220                    (lets (list name `(%inc-ptr ,stack-ptr ,offset)))))))
221              (let* ((pair (list name (next-scalar-arg argtype))))
222                (when name (lets pair))))
223            #+nil
224            (when (or (typep argtype 'foreign-pointer-type)
225                      (typep argtype 'foreign-array-type))
226              (dynamic-extent-names name))
227            (when use-fp-args (set-fp-regs-form)))))))))
228
229(defun darwin32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
230  (unless (eq return-type *void-foreign-type*)
231    ;; Coerce SINGLE-FLOAT result to DOUBLE-FLOAT
232    (when (typep return-type 'foreign-single-float-type)
233      (setq result `(float ,result 0.0d0)))   
234    (when (typep return-type 'foreign-record-type)
235      ;;; Would have been mapped to :VOID unless record-type contained
236      ;;; a single scalar field.
237      (let* ((field0 (car (foreign-record-type-fields return-type))))
238        (setq result (%foreign-access-form struct-return-arg
239                                           (foreign-record-field-type field0)
240                                           0
241                                           nil)
242              return-type (foreign-record-field-type field0))))
243    (let* ((return-type-keyword (foreign-type-to-representation-type return-type))
244           (result-ptr (case return-type-keyword
245                   ((:single-float :double-float)
246                    fp-args-ptr)
247                   (t stack-ptr))))
248      `(setf (,
249              (case return-type-keyword
250                                 (:address '%get-ptr)
251                                 (:signed-doubleword '%%get-signed-longlong)
252                                 (:unsigned-doubleword '%%get-unsigned-longlong)
253                                 ((:double-float :single-float)
254                                  '%get-double-float)
255                                 (:unsigned-fullword '%get-unsigned-long)
256                                 (t '%get-long )
257                                 ) ,result-ptr 0) ,result))))
258
Note: See TracBrowser for help on using the repository browser.