source: branches/qres/ccl/lib/ffi-linuxppc32.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: 10.7 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;;; LinuxPPC32:
20;;; Structures are never actually passed by value; the caller
21;;; instead passes a pointer to the structure or a copy of it.
22;;; In the EABI (which Linux uses, as opposed to the SVR4 ABI)
23;;; structures are always "returned" by passing a pointer to
24;;; a caller-allocated structure in the first argument.
25(defun linux32::record-type-returns-structure-as-first-arg (rtype)
26  (when (and rtype
27             (not (typep rtype 'unsigned-byte))
28             (not (member rtype *foreign-representation-type-keywords*
29                          :test #'eq)))
30    (let* ((ftype (if (typep rtype 'foreign-type)
31                    rtype
32                    (parse-foreign-type rtype))))
33      (typep ftype 'foreign-record-type))))
34
35
36(defun linux32::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
37  (let* ((result-type-spec (or (car (last args)) :void))
38         (enclosing-form nil)
39         (result-form nil))
40    (multiple-value-bind (result-type error)
41        (ignore-errors (parse-foreign-type result-type-spec))
42      (if error
43        (setq result-type-spec :void result-type *void-foreign-type*)
44        (setq args (butlast args)))
45      (collect ((argforms))
46        (when (eq (car args) :monitor-exception-ports)
47          (argforms (pop args)))
48        (when (typep result-type 'foreign-record-type)
49          (setq result-form (pop args))
50          (if (linux32::record-type-returns-structure-as-first-arg result-type)
51            (progn
52              (setq result-type *void-foreign-type*
53                    result-type-spec :void)
54              (argforms :address)
55              (argforms result-form))
56            ;; This only happens in the SVR4 ABI.
57            (progn
58              (setq result-type (parse-foreign-type :unsigned-doubleword)
59                    result-type-spec :unsigned-doubleword
60                    enclosing-form `(setf (%%get-unsigned-longlong ,result-form 0))))))
61        (unless (evenp (length args))
62          (error "~s should be an even-length list of alternating foreign types and values" args))       
63        (do* ((args args (cddr args)))
64             ((null args))
65          (let* ((arg-type-spec (car args))
66                 (arg-value-form (cadr args)))
67            (if (or (member arg-type-spec *foreign-representation-type-keywords*
68                           :test #'eq)
69                    (typep arg-type-spec 'unsigned-byte))
70              (progn
71                (argforms arg-type-spec)
72                (argforms arg-value-form))
73              (let* ((ftype (parse-foreign-type arg-type-spec)))
74                (if (typep ftype 'foreign-record-type)
75                  (progn
76                    (argforms :address)
77                    (argforms arg-value-form))
78                  (progn
79                    (argforms (foreign-type-to-representation-type ftype))
80                    (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))))
81        (argforms (foreign-type-to-representation-type result-type))
82        (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
83          (if enclosing-form
84            `(,@enclosing-form ,call)
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(defun linux32::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
97  (declare (ignore fp-args-ptr))
98  (collect ((lets)
99            (rlets)
100            (dynamic-extent-names))
101    (let* ((rtype (parse-foreign-type result-spec)))
102      (when (typep rtype 'foreign-record-type)
103        (let* ((bits (ensure-foreign-type-bits rtype)))
104          (if (<= bits 64)
105            (rlets (list struct-result-name (foreign-record-type-name rtype)))
106            (setq argvars (cons struct-result-name argvars)
107                  argspecs (cons :address argspecs)
108                  rtype *void-foreign-type*))))
109          (let* ((offset  96)
110                 (gpr 0)
111                 (fpr 32))
112            (do* ((argvars argvars (cdr argvars))
113                  (argspecs argspecs (cdr argspecs)))
114                 ((null argvars)
115                  (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 0 #|wrong|#))
116              (let* ((name (car argvars))
117                     (spec (car argspecs))
118                     (nextgpr gpr)
119                     (nextfpr fpr)
120                     (nextoffset offset)
121                     (target gpr)
122                     (bias 0)
123                     (argtype (parse-foreign-type spec)))
124                (if (typep argtype 'foreign-record-type)
125                  (setq argtype (parse-foreign-type :address)))
126                (let* ((access-form
127                        `(,(cond
128                            ((typep argtype 'foreign-single-float-type)
129                             (incf nextfpr 8)
130                             (if (< fpr 96)
131                               (setq target fpr)
132                               (setq target (+ offset (logand offset 4))
133                                     nextoffset (+ target 8)))
134                             '%get-single-float-from-double-ptr)
135                            ((typep argtype 'foreign-double-float-type)
136                             (incf nextfpr 8)
137                             (if (< fpr 96)
138                               (setq target fpr)
139                               (setq target (+ offset (logand offset 4))
140                                     nextoffset (+ target 8)))
141                             '%get-double-float)
142                            ((and (typep argtype 'foreign-integer-type)
143                                  (= (foreign-integer-type-bits argtype) 64)
144                                  (foreign-integer-type-signed argtype))
145                             (if (< gpr 56)
146                                     (setq target (+ gpr (logand gpr 4))
147                                           nextgpr (+ 8 target))
148                                     (setq target (+ offset (logand offset 4))
149                                           nextoffset (+ 8 offset)))
150                                   '%%get-signed-longlong)
151                            ((and (typep argtype 'foreign-integer-type)
152                                  (= (foreign-integer-type-bits argtype) 64)
153                                  (not (foreign-integer-type-signed argtype)))
154                             (if (< gpr 56)
155                               (setq target (+ gpr (logand gpr 4))
156                                     nextgpr (+ 8 target))
157                               (setq target (+ offset (logand offset 4))
158                                     nextoffset (+ 8 offset)))
159                             '%%get-unsigned-longlong)
160                            (t
161                             (incf nextgpr 4)
162                             (if (< gpr 64)
163                               (setq target gpr)
164                               (setq target offset nextoffset (+ offset 4)))
165                             (cond ((typep argtype 'foreign-pointer-type) '%get-ptr)
166                                   ((typep argtype 'foreign-integer-type)
167                                    (let* ((bits (foreign-integer-type-bits argtype))
168                                           (signed (foreign-integer-type-signed argtype)))
169                                      (cond ((<= bits 8)
170                                             (setq bias 3)
171                                             (if signed
172                                               '%get-signed-byte '
173                                               '%get-unsigned-byte))
174                                            ((<= bits 16)
175                                             (setq bias 2)
176                                             (if signed
177                                               '%get-signed-word 
178                                               '%get-unsigned-word))
179                                            ((<= bits 32)
180                                             (if signed
181                                               '%get-signed-long 
182                                               '%get-unsigned-long))
183                                            (t
184                                             (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
185                                   (t
186                                    (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
187                          ,stack-ptr
188                          ,(+ target bias))))
189                  (when name (lets (list name access-form)))
190                  #+nil
191                  (when (eq spec :address)
192                    (dynamic-extent-names name))
193                  (setq gpr nextgpr fpr nextfpr offset nextoffset))))))))
194
195(defun linux32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
196  (declare (ignore fp-args-ptr))
197  (unless (eq return-type *void-foreign-type*)
198    (when (typep return-type 'foreign-single-float-type)
199      (setq result `(float ,result 0.0d0)))   
200    (let* ((return-type-keyword
201            (if (typep return-type 'foreign-record-type)
202              (progn
203                (setq result `(%%get-unsigned-longlong ,struct-return-arg 0))
204                :unsigned-doubleword)
205              (foreign-type-to-representation-type return-type)))
206           (offset (case return-type-keyword
207                   ((:single-float :double-float)
208                    8)
209                   (t 0))))
210      `(setf (,
211              (case return-type-keyword
212                (:address '%get-ptr)
213                (:signed-doubleword '%%get-signed-longlong)
214                (:unsigned-doubleword '%%get-unsigned-longlong)
215                ((:double-float :single-float) '%get-double-float)
216                (t '%get-long)) ,stack-ptr ,offset) ,result))))
217     
218                 
Note: See TracBrowser for help on using the repository browser.