source: trunk/source/lib/ffi-linuxarm.lisp @ 14423

Last change on this file since 14423 was 14119, checked in by gb, 9 years ago

Changes from ARM branch. Need testing ...

File size: 9.3 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2010 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;;; LinuxARM:
20;;; Structures whose size is 64 bits are passed by value; the caller
21;;; instead passes a pointer to the structure or a copy of it.
22;;; Structures whose size is <= 32 bits are returned as scalars.
23(defun arm-linux::record-type-returns-structure-as-first-arg (rtype)
24  (when (and rtype
25             (not (typep rtype 'unsigned-byte))
26             (not (member rtype *foreign-representation-type-keywords*
27                          :test #'eq)))
28    (let* ((ftype (if (typep rtype 'foreign-type)
29                    rtype
30                    (parse-foreign-type rtype))))
31      (when (typep ftype 'foreign-record-type)
32        (ensure-foreign-type-bits ftype)
33        (> (foreign-type-bits ftype) 32)))))
34
35
36(defun arm-linux::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 (typep result-type 'foreign-record-type)
47          (setq result-form (pop args))
48          (if (arm-linux::record-type-returns-structure-as-first-arg result-type)
49            (progn
50              (setq result-type *void-foreign-type*
51                    result-type-spec :void)
52              (argforms :address)
53              (argforms result-form))
54            ;; This only happens in the SVR4 ABI.
55            (progn
56              (setq result-type (parse-foreign-type :unsigned-doubleword)
57                    result-type-spec :unsigned-doubleword
58                    enclosing-form `(setf (%%get-unsigned-longlong ,result-form 0))))))
59        (unless (evenp (length args))
60          (error "~s should be an even-length list of alternating foreign types and values" args))       
61        (do* ((args args (cddr args)))
62             ((null args))
63          (let* ((arg-type-spec (car args))
64                 (arg-value-form (cadr args)))
65            (if (or (member arg-type-spec *foreign-representation-type-keywords*
66                           :test #'eq)
67                    (typep arg-type-spec 'unsigned-byte))
68              (progn
69                (argforms arg-type-spec)
70                (argforms arg-value-form))
71              (let* ((ftype (parse-foreign-type arg-type-spec)))
72                (if (typep ftype 'foreign-record-type)
73                  (progn
74                    (argforms :address)
75                    (argforms arg-value-form))
76                  (progn
77                    (argforms (foreign-type-to-representation-type ftype))
78                    (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))))
79        (argforms (foreign-type-to-representation-type result-type))
80        (let* ((call (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))
81          (if enclosing-form
82            `(,@enclosing-form ,call)
83            call))))))
84
85;;; Return 7 values:
86;;; A list of RLET bindings
87;;; A list of LET* bindings
88;;; A list of DYNAMIC-EXTENT declarations for the LET* bindings
89;;; A list of initializaton forms for (some) structure args
90;;; A FOREIGN-TYPE representing the "actual" return type.
91;;; A form which can be used to initialize FP-ARGS-PTR, relative
92;;;  to STACK-PTR.  (This is unused on linuxarm.)
93;;; The byte offset of the foreign return address, relative to STACK-PTR
94(defun arm-linux::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
95  (declare (ignore fp-args-ptr))
96  (collect ((lets)
97            (rlets)
98            (dynamic-extent-names))
99    (let* ((rtype (parse-foreign-type result-spec)))
100      (when (typep rtype 'foreign-record-type)
101        (let* ((bits (ensure-foreign-type-bits rtype)))
102          (if (<= bits 64)
103            (rlets (list struct-result-name (foreign-record-type-name rtype)))
104            (setq argvars (cons struct-result-name argvars)
105                  argspecs (cons :address argspecs)
106                  rtype *void-foreign-type*))))
107          (let* ((offset 0)
108                 (nextoffset offset))
109            (do* ((argvars argvars (cdr argvars))
110                  (argspecs argspecs (cdr argspecs)))
111                 ((null argvars)
112                  (values (rlets) (lets) (dynamic-extent-names) nil rtype nil 0 #|wrong|#))
113              (let* ((name (car argvars))
114                     (spec (car argspecs))
115                     (argtype (parse-foreign-type spec)))
116                (if (typep argtype 'foreign-record-type)
117                  (setq argtype (parse-foreign-type :address)))
118                (let* ((access-form
119                        `(,(cond
120                            ((typep argtype 'foreign-single-float-type)
121                             (setq nextoffset (+ offset 4))
122                             '%get-single-float-from-double-ptr)
123                            ((typep argtype 'foreign-double-float-type)
124                             (when (logtest offset 4)
125                               (incf offset 4))
126                             (setq nextoffset (+ offset 8))
127                             '%get-double-float)
128                            ((and (typep argtype 'foreign-integer-type)
129                                  (= (foreign-integer-type-bits argtype) 64)
130                                  (foreign-integer-type-signed argtype))
131                             (when (logtest offset 4)
132                               (incf offset 4))
133                             (setq nextoffset (+ offset 8))
134                             '%%get-signed-longlong)
135                            ((and (typep argtype 'foreign-integer-type)
136                                  (= (foreign-integer-type-bits argtype) 64)
137                                  (not (foreign-integer-type-signed argtype)))
138                             (when (logtest offset 4)
139                               (incf offset 4))
140                             (setq nextoffset (+ offset 8))
141                             '%%get-unsigned-longlong)
142                            (t
143                             (setq nextoffset (+ offset 4))
144                             (cond ((typep argtype 'foreign-pointer-type) '%get-ptr)
145                                   ((typep argtype 'foreign-integer-type)
146                                    (let* ((bits (foreign-integer-type-bits argtype))
147                                           (signed (foreign-integer-type-signed argtype)))
148                                      (cond ((<= bits 8)
149                                             (if signed
150                                               '%get-signed-byte '
151                                               '%get-unsigned-byte))
152                                            ((<= bits 16)
153                                             (if signed
154                                               '%get-signed-word 
155                                               '%get-unsigned-word))
156                                            ((<= bits 32)
157                                             (if signed
158                                               '%get-signed-long 
159                                               '%get-unsigned-long))
160                                            (t
161                                             (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
162                                   (t
163                                    (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
164                          ,stack-ptr
165                          ,offset)))
166                  (when name (lets (list name access-form)))
167                  (setq offset nextoffset))))))))
168
169(defun arm-linux::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
170  (declare (ignore fp-args-ptr))
171  (unless (eq return-type *void-foreign-type*)
172    (let* ((return-type-keyword
173            (if (typep return-type 'foreign-record-type)
174              (progn
175                (setq result `(%%get-unsigned-longlong ,struct-return-arg 0))
176                :unsigned-doubleword)
177              (foreign-type-to-representation-type return-type)))
178           (offset -8))
179      `(setf (,
180              (case return-type-keyword
181                (:address '%get-ptr)
182                (:signed-doubleword '%%get-signed-longlong)
183                (:unsigned-doubleword '%%get-unsigned-longlong)
184                ((:double-float :single-float) '%get-double-float)
185                (t '%get-long)) ,stack-ptr ,offset) ,result))))
186     
187                 
Note: See TracBrowser for help on using the repository browser.