1 ;;;; VOPs and other machine-specific support routines for call-out to C
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 ;;; Return the number of bytes needed for the current non-descriptor
15 ;;; stack frame. Non-descriptor stack frames must be multiples of 16
16 ;;; bytes under the PPC SVr4 ABI (though the EABI may be less
17 ;;; restrictive). On linux, two words are reserved for the stack
18 ;;; backlink and saved LR (see SB!VM::NUMBER-STACK-DISPLACEMENT).
20 (defconstant +stack-alignment-bytes+
21 ;; Duh. PPC Linux (and VxWorks) adhere to the EABI.
26 (defun my-make-wired-tn (prim-type-name sc-name offset)
27 (make-wired-tn (primitive-type-or-lose prim-type-name)
28 (sc-number-or-lose sc-name)
34 ;; SVR4 [a]abi wants two words on stack (callee saved lr,
36 #!-darwin (stack-frame-size 2)
37 ;; PowerOpen ABI wants 8 words on the stack corresponding to GPR3-10
38 ;; in addition to the 6 words of link area (see number-stack-displacement)
39 #!+darwin (stack-frame-size (+ 8 6)))
41 (defun int-arg (state prim-type reg-sc stack-sc)
42 (let ((reg-args (arg-state-gpr-args state)))
44 (setf (arg-state-gpr-args state) (1+ reg-args))
45 (my-make-wired-tn prim-type reg-sc (+ reg-args nl0-offset)))
47 (let ((frame-size (arg-state-stack-frame-size state)))
48 (setf (arg-state-stack-frame-size state) (1+ frame-size))
49 (my-make-wired-tn prim-type stack-sc frame-size))))))
51 (define-alien-type-method (integer :arg-tn) (type state)
52 (if (alien-integer-type-signed type)
53 (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
54 (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
56 (define-alien-type-method (system-area-pointer :arg-tn) (type state)
57 (declare (ignore type))
58 (int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
60 ;;; If a single-float arg has to go on the stack, it's promoted to
61 ;;; double. That way, C programs can get subtle rounding errors when
62 ;;; unrelated arguments are introduced.
65 (define-alien-type-method (single-float :arg-tn) (type state)
66 (declare (ignore type))
67 (let* ((fprs (arg-state-fpr-args state)))
69 (incf (arg-state-fpr-args state))
70 ;; Assign outgoing FPRs starting at FP1
71 (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
73 (let* ((stack-offset (arg-state-stack-frame-size state)))
74 (if (oddp stack-offset)
76 (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
77 (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
80 (define-alien-type-method (single-float :arg-tn) (type state)
81 (declare (ignore type))
82 (let* ((fprs (arg-state-fpr-args state))
83 (gprs (arg-state-gpr-args state)))
84 (cond ((< gprs 8) ; and by implication also (< fprs 13)
85 ;; Corresponding GPR is kept empty for functions with fixed args
86 (incf (arg-state-gpr-args state))
87 (incf (arg-state-fpr-args state))
88 ;; Assign outgoing FPRs starting at FP1
89 (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
91 ;; According to PowerOpen ABI, we need to pass those both in the
92 ;; FPRs _and_ the stack. However empiric testing on OS X/gcc
93 ;; shows they are only passed in FPRs, AFAICT.
95 ;; "I" in "AFAICT" probably refers to PRM. -- CSR, still
96 ;; reverse-engineering comments in 2003 :-)
97 (incf (arg-state-fpr-args state))
98 (incf (arg-state-stack-frame-size state))
99 (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
101 ;; Pass on stack only
102 (let ((stack-offset (arg-state-stack-frame-size state)))
103 (incf (arg-state-stack-frame-size state))
104 (my-make-wired-tn 'single-float 'single-stack stack-offset))))))
106 (define-alien-type-method (double-float :arg-tn) (type state)
107 (declare (ignore type))
108 (let* ((fprs (arg-state-fpr-args state)))
110 (incf (arg-state-fpr-args state))
111 ;; Assign outgoing FPRs starting at FP1
112 (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
114 (let* ((stack-offset (arg-state-stack-frame-size state)))
115 (if (oddp stack-offset)
117 (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
118 (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
121 (define-alien-type-method (double-float :arg-tn) (type state)
122 (declare (ignore type))
123 (let ((fprs (arg-state-fpr-args state))
124 (gprs (arg-state-gpr-args state)))
125 (cond ((< gprs 8) ; and by implication also (< fprs 13)
126 ;; Corresponding GPRs are also kept empty
127 (incf (arg-state-gpr-args state) 2)
128 (when (> (arg-state-gpr-args state) 8)
129 ;; Spill one word to stack
130 (decf (arg-state-gpr-args state))
131 (incf (arg-state-stack-frame-size state)))
132 (incf (arg-state-fpr-args state))
133 ;; Assign outgoing FPRs starting at FP1
134 (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
136 ;; According to PowerOpen ABI, we need to pass those both in the
137 ;; FPRs _and_ the stack. However empiric testing on OS X/gcc
138 ;; shows they are only passed in FPRs, AFAICT.
139 (incf (arg-state-stack-frame-size state) 2)
140 (incf (arg-state-fpr-args state))
141 (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
143 ;; Pass on stack only
144 (let ((stack-offset (arg-state-stack-frame-size state)))
145 (incf (arg-state-stack-frame-size state) 2)
146 (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
148 ;;; Result state handling
150 (defstruct result-state
153 (defun result-reg-offset (slot)
158 ;;; FIXME: These #!-DARWIN methods should be adjusted to take a state
159 ;;; argument, firstly because that's our "official" API (see
160 ;;; src/code/host-alieneval) and secondly because that way we can
161 ;;; probably have less duplication of code. -- CSR, 2003-07-29
164 (define-alien-type-method (system-area-pointer :result-tn) (type)
165 (declare (ignore type))
166 (my-make-wired-tn 'system-area-pointer 'sap-reg nl0-offset))
169 (define-alien-type-method (system-area-pointer :result-tn) (type state)
170 (declare (ignore type))
171 (let ((num-results (result-state-num-results state)))
172 (setf (result-state-num-results state) (1+ num-results))
173 (my-make-wired-tn 'system-area-pointer 'sap-reg
174 (result-reg-offset num-results))))
177 (define-alien-type-method (single-float :result-tn) (type)
178 (declare (ignore type state))
179 (my-make-wired-tn 'single-float 'single-reg 1))
182 (define-alien-type-method (single-float :result-tn) (type state)
183 (declare (ignore type state))
184 (my-make-wired-tn 'single-float 'single-reg 1))
187 (define-alien-type-method (double-float :result-tn) (type)
188 (declare (ignore type))
189 (my-make-wired-tn 'double-float 'double-reg 1))
192 (define-alien-type-method (double-float :result-tn) (type state)
193 (declare (ignore type state))
194 (my-make-wired-tn 'double-float 'double-reg 1))
197 (define-alien-type-method (values :result-tn) (type)
198 (mapcar #'(lambda (type)
199 (invoke-alien-type-method :result-tn type))
200 (alien-values-type-values type)))
203 (define-alien-type-method (values :result-tn) (type state)
204 (let ((values (alien-values-type-values type)))
205 (when (> (length values) 2)
206 (error "Too many result values from c-call."))
207 (mapcar #'(lambda (type)
208 (invoke-alien-type-method :result-tn type state))
211 (define-alien-type-method (integer :result-tn) (type)
212 (if (alien-integer-type-signed type)
213 (my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset)
214 (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset)))
217 (define-alien-type-method (integer :result-tn) (type state)
218 (let ((num-results (result-state-num-results state)))
219 (setf (result-state-num-results state) (1+ num-results))
220 (multiple-value-bind (ptype reg-sc)
221 (if (alien-integer-type-signed type)
222 (values 'signed-byte-32 'signed-reg)
223 (values 'unsigned-byte-32 'unsigned-reg))
224 (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
227 (!def-vm-support-routine make-call-out-tns (type)
228 (declare (type alien-fun-type type))
229 (let ((arg-state (make-arg-state)))
231 (dolist (arg-type (alien-fun-type-arg-types type))
232 (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
233 (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
234 (* (arg-state-stack-frame-size arg-state) n-word-bytes)
236 (invoke-alien-type-method
238 (alien-fun-type-result-type type)
239 #!+darwin (make-result-state))))))
242 (deftransform %alien-funcall ((function type &rest args))
243 (assert (sb!c::constant-lvar-p type))
244 (let* ((type (sb!c::lvar-value type))
245 (arg-types (alien-fun-type-arg-types type))
246 (result-type (alien-fun-type-result-type type)))
247 (assert (= (length arg-types) (length args)))
248 ;; We need to do something special for 64-bit integer arguments
250 (if (or (some #'(lambda (type)
251 (and (alien-integer-type-p type)
252 (> (sb!alien::alien-integer-type-bits type) 32)))
254 (and (alien-integer-type-p result-type)
255 (> (sb!alien::alien-integer-type-bits result-type) 32)))
256 (collect ((new-args) (lambda-vars) (new-arg-types))
257 (dolist (type arg-types)
258 (let ((arg (gensym)))
260 (cond ((and (alien-integer-type-p type)
261 (> (sb!alien::alien-integer-type-bits type) 32))
262 ;; 64-bit long long types are stored in
263 ;; consecutive locations, most significant word
264 ;; first (big-endian).
265 (new-args `(ash ,arg -32))
266 (new-args `(logand ,arg #xffffffff))
267 (if (alien-integer-type-signed type)
268 (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
269 (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
270 (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
273 (new-arg-types type)))))
274 (cond ((and (alien-integer-type-p result-type)
275 (> (sb!alien::alien-integer-type-bits result-type) 32))
276 (let ((new-result-type
277 (let ((sb!alien::*values-type-okay* t))
279 (if (alien-integer-type-signed result-type)
280 '(values (signed 32) (unsigned 32))
281 '(values (unsigned 32) (unsigned 32)))
282 (sb!kernel:make-null-lexenv)))))
283 `(lambda (function type ,@(lambda-vars))
284 (declare (ignore type))
285 (multiple-value-bind (high low)
286 (%alien-funcall function
287 ',(make-alien-fun-type
288 :arg-types (new-arg-types)
289 :result-type new-result-type)
291 (logior low (ash high 32))))))
293 `(lambda (function type ,@(lambda-vars))
294 (declare (ignore type))
295 (%alien-funcall function
296 ',(make-alien-fun-type
297 :arg-types (new-arg-types)
298 :result-type result-type)
300 (sb!c::give-up-ir1-transform))))
302 (define-vop (foreign-symbol-address)
303 (:translate foreign-symbol-address)
306 (:arg-types (:constant simple-base-string))
307 (:info foreign-symbol)
308 (:results (res :scs (sap-reg)))
309 (:result-types system-area-pointer)
311 (inst lr res (make-fixup (extern-alien-name foreign-symbol) :foreign))))
313 (define-vop (call-out)
314 (:args (function :scs (sap-reg) :target cfunc)
316 (:results (results :more t))
317 (:ignore args results)
319 (:temporary (:sc any-reg :offset cfunc-offset
320 :from (:argument 0) :to (:result 0)) cfunc)
321 (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
322 (:temporary (:scs (non-descriptor-reg)) temp)
325 (let ((cur-nfp (current-nfp-tn vop)))
327 (store-stack-tn nfp-save cur-nfp))
328 (inst lr temp (make-fixup (extern-alien-name "call_into_c") :foreign))
330 (move cfunc function)
333 (load-stack-tn cur-nfp nfp-save)))))
336 (define-vop (alloc-number-stack-space)
338 (:results (result :scs (sap-reg any-reg)))
339 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
341 (unless (zerop amount)
342 ;; FIXME: I don't understand why we seem to be adding
343 ;; NUMBER-STACK-DISPLACEMENT twice here. Weird. -- CSR,
345 (let ((delta (- (logandc2 (+ amount number-stack-displacement
346 +stack-alignment-bytes+)
347 +stack-alignment-bytes+))))
348 (cond ((>= delta (ash -1 16))
349 (inst stwu nsp-tn nsp-tn delta))
352 (inst stwux nsp-tn nsp-tn temp)))))
353 (unless (location= result nsp-tn)
354 ;; They are only location= when the result tn was allocated by
355 ;; make-call-out-tns above, which takes the number-stack-displacement
356 ;; into account itself.
357 (inst addi result nsp-tn number-stack-displacement))))
359 (define-vop (dealloc-number-stack-space)
363 (unless (zerop amount)
364 (let ((delta (logandc2 (+ amount number-stack-displacement
365 +stack-alignment-bytes+)
366 +stack-alignment-bytes+)))
367 (cond ((< delta (ash 1 16))
368 (inst addi nsp-tn nsp-tn delta))
370 (inst lwz nsp-tn nsp-tn 0)))))))