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 (aver (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 (aver (= (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-sap)
303 (:translate foreign-symbol-sap)
306 (:arg-types (:constant simple-string))
307 (:info foreign-symbol)
308 (:results (res :scs (sap-reg)))
309 (:result-types system-area-pointer)
311 (inst lr res (make-fixup foreign-symbol :foreign))))
314 (define-vop (foreign-symbol-dataref-sap)
315 (:translate foreign-symbol-dataref-sap)
318 (:arg-types (:constant simple-string))
319 (:info foreign-symbol)
320 (:results (res :scs (sap-reg)))
321 (:result-types system-area-pointer)
322 (:temporary (:scs (non-descriptor-reg)) addr)
324 (inst lr addr (make-fixup foreign-symbol :foreign-dataref))
327 (define-vop (call-out)
328 (:args (function :scs (sap-reg) :target cfunc)
330 (:results (results :more t))
331 (:ignore args results)
333 (:temporary (:sc any-reg :offset cfunc-offset
334 :from (:argument 0) :to (:result 0)) cfunc)
335 (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
336 (:temporary (:scs (non-descriptor-reg)) temp)
339 (let ((cur-nfp (current-nfp-tn vop)))
341 (store-stack-tn nfp-save cur-nfp))
342 (inst lr temp (make-fixup "call_into_c" :foreign))
344 (move cfunc function)
347 (load-stack-tn cur-nfp nfp-save)))))
350 (define-vop (alloc-number-stack-space)
352 (:results (result :scs (sap-reg any-reg)))
353 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
355 (unless (zerop amount)
356 ;; FIXME: I don't understand why we seem to be adding
357 ;; NUMBER-STACK-DISPLACEMENT twice here. Weird. -- CSR,
359 (let ((delta (- (logandc2 (+ amount number-stack-displacement
360 +stack-alignment-bytes+)
361 +stack-alignment-bytes+))))
362 (cond ((>= delta (ash -1 16))
363 (inst stwu nsp-tn nsp-tn delta))
366 (inst stwux nsp-tn nsp-tn temp)))))
367 (unless (location= result nsp-tn)
368 ;; They are only location= when the result tn was allocated by
369 ;; make-call-out-tns above, which takes the number-stack-displacement
370 ;; into account itself.
371 (inst addi result nsp-tn number-stack-displacement))))
373 (define-vop (dealloc-number-stack-space)
377 (unless (zerop amount)
378 (let ((delta (logandc2 (+ amount number-stack-displacement
379 +stack-alignment-bytes+)
380 +stack-alignment-bytes+)))
381 (cond ((< delta (ash 1 16))
382 (inst addi nsp-tn nsp-tn delta))
384 (inst lwz nsp-tn nsp-tn 0)))))))
388 (defun alien-callback-accessor-form (type sap offset)
389 ;; Unaligned access is slower, but possible, so this is nice and simple.
390 `(deref (sap-alien (sap+ ,sap ,offset) (* ,type))))
392 ;;; The "Mach-O Runtime Conventions" document for OS X almost specifies
393 ;;; the calling convention (it neglects to mention that the linkage
394 ;;; area is 24 bytes).
395 (defconstant n-foreign-linkage-area-bytes 24)
397 ;;; Returns a vector in static space containing machine code for the
399 (defun alien-callback-assembler-wrapper (index result-type argument-types)
401 (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n))
403 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) :offset n)))
404 (let* ((segment (make-segment)))
406 ;; To save our arguments, we follow the algorithm sketched in the
407 ;; "PowerPC Calling Conventions" section of that document.
408 (let ((words-processed 0)
409 (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10)))
410 (fprs (mapcar #'make-fpr '(1 2 3 4 5 6 7 8 9 10 11 12 13)))
411 (stack-pointer (make-gpr 1)))
412 (labels ((out-of-registers-error ()
413 (error "Too many arguments in callback"))
414 (save-arg (type words)
415 (let ((integerp (not (alien-float-type-p type)))
416 (offset (+ (* words-processed n-word-bytes)
417 n-foreign-linkage-area-bytes)))
423 (inst stw gpr stack-pointer offset)
424 (out-of-registers-error))
425 (incf words-processed)))
426 ;; The handling of floats is a little ugly
427 ;; because we hard-code the number of words
428 ;; for single- and double-floats.
429 ((alien-single-float-type-p type)
431 (let ((fpr (pop fprs)))
433 (inst stfs fpr stack-pointer offset)
434 (out-of-registers-error)))
435 (incf words-processed))
436 ((alien-double-float-type-p type)
437 (setf gprs (cddr gprs))
438 (let ((fpr (pop fprs)))
440 (inst stfd fpr stack-pointer offset)
441 (out-of-registers-error)))
442 (incf words-processed 2))
444 (bug "Unknown alien floating point type: ~S" type))))))
447 (mapcar (lambda (arg)
448 (ceiling (alien-type-bits arg) n-word-bits))
450 ;; Set aside room for the return area just below sp, then
451 ;; actually call funcall3: funcall3 (call-alien-function,
452 ;; index, args, return-area)
454 ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to be
455 ;; because they're word-aligned. Kinda gross, but hey ...
456 (let* ((n-return-area-words
457 (ceiling (or (alien-type-bits result-type) 0) n-word-bits))
458 (n-return-area-bytes (* n-return-area-words n-word-bytes))
459 ;; FIXME: magic constant, and probably n-args-bytes
460 (args-size (* 3 n-word-bytes))
461 ;; FIXME: n-frame-bytes?
463 (+ n-foreign-linkage-area-bytes n-return-area-bytes args-size)))
464 (destructuring-bind (sp r0 arg1 arg2 arg3 arg4)
465 (mapcar #'make-gpr '(1 0 3 4 5 6))
466 (flet ((load-address-into (reg addr)
467 (let ((high (ldb (byte 16 16) addr))
468 (low (ldb (byte 16 0) addr)))
470 (inst slwi reg reg 16)
471 (inst ori reg reg low))))
474 arg1 (get-lisp-obj-address #'enter-alien-callback))
475 (inst li arg2 (fixnumize index))
476 (inst addi arg3 sp n-foreign-linkage-area-bytes)
477 ;; FIXME: This was (- (* RETURN-AREA-SIZE N-WORD-BYTES)), while
478 ;; RETURN-AREA-SIZE was (* N-RETURN-AREA-WORDS N-WORD-BYTES):
479 ;; I assume the intention was (- N-RETURN-AREA-BYTES), but who knows?
481 (inst addi arg4 sp (- n-return-area-bytes))
482 ;; FIXME! FIXME FIXME: What does this FIXME refer to?
483 ;; Save sp, setup the frame
485 (inst stw r0 sp (* 2 n-word-bytes)) ; FIXME: magic constant
486 (inst stwu sp sp (- frame-size))
488 (load-address-into r0 (foreign-symbol-address "funcall3"))
491 ;; We're back! Restore sp and lr, load the return value from just
492 ;; under sp, and return.
494 (inst lwz r0 sp (* 2 n-word-bytes))
496 (loop with gprs = (mapcar #'make-gpr '(3 4))
497 repeat n-return-area-words
499 for offset downfrom (- n-word-bytes) by n-word-bytes
502 (bug "Out of return registers in alien-callback trampoline."))
503 (inst lwz gpr sp offset))
505 (finalize-segment segment)
506 ;; Now that the segment is done, convert it to a static
507 ;; vector we can point foreign code to.
508 (let ((buffer (sb!assem::segment-buffer segment)))
509 (make-static-vector (length buffer)
510 :element-type '(unsigned-byte 8)
511 :initial-contents buffer))))))