source: branches/qres/ccl/lib/ffi-linuxppc64.lisp @ 14308

Last change on this file since 14308 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.1 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;;; LinuxPPC64
20;;; Structures whose size is less than 64 bits are passed "right-justified"
21;;; in a GPR.
22;;; Larger structures passed by value are passed in GPRs as N doublewords.
23;;; If the structure would require > 64-bit alignment, this might result
24;;; in some GPRs/parameter area words being skipped.  (We don't handle this).
25;;; All structures - of any size - are returned by passing a pointer
26;;; in the first argument.
27
28(defun linux64::record-type-returns-structure-as-first-arg (rtype)
29  (when (and rtype
30             (not (typep rtype 'unsigned-byte))
31             (not (member rtype *foreign-representation-type-keywords*
32                          :test #'eq)))
33    (let* ((ftype (if (typep rtype 'foreign-type)
34                    rtype
35                    (parse-foreign-type rtype))))
36      (typep ftype 'foreign-record-type))))
37
38(defun linux64::expand-ff-call (callform args &key (arg-coerce #'null-coerce-foreign-arg) (result-coerce #'null-coerce-foreign-result))
39  (let* ((result-type-spec (or (car (last args)) :void)))
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-type *void-foreign-type*
50                result-type-spec :void)
51          (argforms :address)
52          (argforms (pop args)))
53        (unless (evenp (length args))
54          (error "~s should be an even-length list of alternating foreign types and values" args))       
55        (do* ((args args (cddr args)))
56             ((null args))
57          (let* ((arg-type-spec (car args))
58                 (arg-value-form (cadr args)))
59            (if (or (member arg-type-spec *foreign-representation-type-keywords*
60                            :test #'eq)
61                    (typep arg-type-spec 'unsigned-byte))
62              (progn
63                (argforms arg-type-spec)
64                (argforms arg-value-form))
65              (let* ((ftype (parse-foreign-type arg-type-spec)))
66                (if (typep ftype 'foreign-record-type)
67                  (let* ((bits (ensure-foreign-type-bits ftype)))
68                    (if (< bits 64)
69                      (progn
70                        (argforms :unsigned-doubleword)
71                        (argforms `(ash (%%get-unsigned-longlong ,arg-value-form 0) ,(- bits 64))))
72                      (progn
73                        (argforms (ceiling bits 64))
74                        (argforms arg-value-form))))
75                  (progn
76                    (argforms (foreign-type-to-representation-type ftype))
77                    (argforms (funcall arg-coerce arg-type-spec arg-value-form))))))))
78        (argforms (foreign-type-to-representation-type result-type))
79        (funcall result-coerce result-type-spec `(,@callform ,@(argforms)))))))
80
81(defun linux64::generate-callback-bindings (stack-ptr fp-args-ptr argvars argspecs result-spec struct-result-name)
82  (collect ((lets)
83            (rlets)
84            (inits)
85            (dynamic-extent-names))
86    (let* ((rtype (parse-foreign-type result-spec))
87           (fp-regs-form nil))
88      (flet ((set-fp-regs-form ()
89               (unless fp-regs-form
90                 (setq fp-regs-form `(%get-ptr ,stack-ptr ,(- ppc64::c-frame.unused-1 ppc64::c-frame.param0))))))
91        (when (typep rtype 'foreign-record-type)
92          (setq argvars (cons struct-result-name argvars)
93                argspecs (cons :address argspecs)
94                rtype *void-foreign-type*))
95        (when (typep rtype 'foreign-float-type)
96          (set-fp-regs-form))
97        (do* ((argvars argvars (cdr argvars))
98              (argspecs argspecs (cdr argspecs))
99              (fp-arg-num 0)
100              (offset 0 (+ offset delta))
101              (delta 8 8)
102              (bias 0 0)
103              (use-fp-args nil nil))
104             ((null argvars)
105              (values (rlets) (lets) (dynamic-extent-names) (inits) rtype fp-regs-form (- ppc64::c-frame.savelr ppc64::c-frame.param0)))
106          (let* ((name (car argvars))
107                 (spec (car argspecs))
108                 (argtype (parse-foreign-type spec))
109                 (bits (ensure-foreign-type-bits argtype)))
110            (if (and (typep argtype 'foreign-record-type)
111                     (< bits 64))
112              (progn
113                (when name (rlets (list name (foreign-record-type-name argtype))))
114                (when name (inits `(setf (%%get-unsigned-longlong ,name 0)
115                                    (ash (%%get-unsigned-longlong ,stack-ptr ,offset)
116                                     ,(- 64 bits))))))
117              (let* ((access-form
118                      `(,(cond
119                          ((typep argtype 'foreign-single-float-type)
120                           (if (< (incf fp-arg-num) 14)
121                             (progn
122                               (setq use-fp-args t)
123                               '%get-single-float-from-double-ptr)
124                             (progn
125                               (setq bias 4)
126                               '%get-single-float)))
127                          ((typep argtype 'foreign-double-float-type)
128                           (if (< (incf fp-arg-num) 14)
129                             (setq use-fp-args t))
130                           '%get-double-float)
131                          ((and (typep argtype 'foreign-integer-type)
132                                (= (foreign-integer-type-bits argtype) 64)
133                                (foreign-integer-type-signed argtype))
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                           '%%get-unsigned-longlong)
139                          ((or (typep argtype 'foreign-pointer-type)
140                               (typep argtype 'foreign-array-type))
141                           '%get-ptr)
142                          ((typep argtype 'foreign-record-type)
143                           (setq delta (* (ceiling bits 64) 8))
144                           '%inc-ptr)
145                          (t
146                           (cond ((typep argtype 'foreign-integer-type)
147                                  (let* ((bits (foreign-integer-type-bits argtype))
148                                         (signed (foreign-integer-type-signed argtype)))
149                                    (cond ((<= bits 8)
150                                           (setq bias 7)
151                                           (if signed
152                                             '%get-signed-byte '
153                                             '%get-unsigned-byte))
154                                          ((<= bits 16)
155                                           (setq bias 6)
156                                           (if signed
157                                             '%get-signed-word 
158                                             '%get-unsigned-word))
159                                          ((<= bits 32)
160                                           (setq bias 4)
161                                           (if signed
162                                             '%get-signed-long 
163                                             '%get-unsigned-long))
164                                          (t
165                                           (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
166                                 (t
167                                  (error "Don't know how to access foreign argument of type ~s" (unparse-foreign-type argtype))))))
168                        ,(if use-fp-args fp-args-ptr stack-ptr)
169                        ,(if use-fp-args (* 8 (1- fp-arg-num))
170                             `(+ ,offset ,bias)))))
171                (when name (lets (list name access-form)))
172                #+nil
173                (when (eq spec :address)
174                  (dynamic-extent-names name))
175                (when use-fp-args (set-fp-regs-form))))))))))
176
177
178;;; All structures are "returned" via the implicit first argument; we'll have
179;;; already translated the return type to :void in that case.
180(defun linux64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
181  (declare (ignore struct-return-arg))
182  (unless (eq return-type *void-foreign-type*)
183    (when (typep return-type 'foreign-single-float-type)
184      (setq result `(float ,result 0.0d0)))   
185    (let* ((return-type-keyword (foreign-type-to-representation-type return-type))
186           (result-ptr (case return-type-keyword
187                   ((:single-float :double-float)
188                    fp-args-ptr)
189                   (t stack-ptr))))
190      `(setf (,
191              (case return-type-keyword
192                                 (:address '%get-ptr)
193                                 (:signed-doubleword '%%get-signed-longlong)
194                                 (:unsigned-doubleword '%%get-unsigned-longlong)
195                                 ((:double-float :single-float)
196                                  (setq stack-ptr `(%get-ptr ,stack-ptr ,(- ppc64::c-frame.unused-1 ppc64::c-frame.param0)))
197                                  '%get-double-float)
198                                 (t '%%get-signed-longlong )
199                                 ) ,result-ptr 0) ,result))))
Note: See TracBrowser for help on using the repository browser.