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 ;;; The Linux/PPC 32bit ABI says:
62 ;;; If a single-float arg has to go on the stack, it's promoted to
67 ;;; Excess floats stored on the stack are stored as floats.
71 (define-alien-type-method (single-float :arg-tn) (type state)
72 (declare (ignore type))
73 (let* ((fprs (arg-state-fpr-args state)))
75 (incf (arg-state-fpr-args state))
76 ;; Assign outgoing FPRs starting at FP1
77 (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
79 (let* ((stack-offset (arg-state-stack-frame-size state)))
80 (setf (arg-state-stack-frame-size state) (+ stack-offset 1))
81 (my-make-wired-tn 'single-float 'single-stack stack-offset))))))
83 ;;; If a single-float arg has to go on the stack, it's promoted to
84 ;;; double. That way, C programs can get subtle rounding errors when
85 ;;; unrelated arguments are introduced.
87 (define-alien-type-method (single-float :arg-tn) (type state)
88 (declare (ignore type))
89 (let* ((fprs (arg-state-fpr-args state))
90 (gprs (arg-state-gpr-args state)))
91 (cond ((< gprs 8) ; and by implication also (< fprs 13)
92 (incf (arg-state-fpr-args state))
93 ;; Assign outgoing FPRs starting at FP1
94 (list (my-make-wired-tn 'single-float 'single-reg (1+ fprs))
95 (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)))
97 ;; See comments below for double-float.
98 (incf (arg-state-fpr-args state))
99 (incf (arg-state-stack-frame-size state))
100 (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
102 ;; Pass on stack only
103 (let ((stack-offset (arg-state-stack-frame-size state)))
104 (incf (arg-state-stack-frame-size state))
105 (my-make-wired-tn 'single-float 'single-stack stack-offset))))))
108 (define-alien-type-method (double-float :arg-tn) (type state)
109 (declare (ignore type))
110 (let* ((fprs (arg-state-fpr-args state)))
112 (incf (arg-state-fpr-args state))
113 ;; Assign outgoing FPRs starting at FP1
114 (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
116 (let* ((stack-offset (arg-state-stack-frame-size state)))
117 (if (oddp stack-offset)
119 (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
120 (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
123 (define-alien-type-method (double-float :arg-tn) (type state)
124 (declare (ignore type))
125 (let ((fprs (arg-state-fpr-args state))
126 (gprs (arg-state-gpr-args state)))
127 (cond ((< gprs 8) ; and by implication also (< fprs 13)
128 (incf (arg-state-fpr-args state))
129 ;; Assign outgoing FPRs starting at FP1
131 ;; The PowerOpen ABI says float values are stored in float
132 ;; regs. But if we're calling a varargs function, we also
133 ;; need to put the float into some gprs. We indicate this
134 ;; to %alien-funcall ir2-convert by making a list of the
135 ;; TNs for the float reg and for the int regs.
137 (list (my-make-wired-tn 'double-float 'double-reg (1+ fprs))
138 (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
139 (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
141 (incf (arg-state-fpr-args state))
142 (list (my-make-wired-tn 'double-float 'double-reg (1+ fprs))
143 (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
144 (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
146 ;; Pass on stack only
147 (let ((stack-offset (arg-state-stack-frame-size state)))
148 (incf (arg-state-stack-frame-size state) 2)
149 (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
151 ;;; Result state handling
153 (defstruct result-state
156 (defun result-reg-offset (slot)
161 ;;; FIXME: These #!-DARWIN methods should be adjusted to take a state
162 ;;; argument, firstly because that's our "official" API (see
163 ;;; src/code/host-alieneval) and secondly because that way we can
164 ;;; probably have less duplication of code. -- CSR, 2003-07-29
166 (define-alien-type-method (system-area-pointer :result-tn) (type state)
167 (declare (ignore type))
168 (let ((num-results (result-state-num-results state)))
169 (setf (result-state-num-results state) (1+ num-results))
170 (my-make-wired-tn 'system-area-pointer 'sap-reg
171 (result-reg-offset num-results))))
173 (define-alien-type-method (single-float :result-tn) (type state)
174 (declare (ignore type state))
175 (my-make-wired-tn 'single-float 'single-reg 1))
177 (define-alien-type-method (double-float :result-tn) (type state)
178 (declare (ignore type state))
179 (my-make-wired-tn 'double-float 'double-reg 1))
181 (define-alien-type-method (values :result-tn) (type state)
182 (let ((values (alien-values-type-values type)))
183 (when (> (length values) 2)
184 (error "Too many result values from c-call."))
185 (mapcar #'(lambda (type)
186 (invoke-alien-type-method :result-tn type state))
189 (define-alien-type-method (integer :result-tn) (type state)
190 (let ((num-results (result-state-num-results state)))
191 (setf (result-state-num-results state) (1+ num-results))
192 (multiple-value-bind (ptype reg-sc)
193 (if (alien-integer-type-signed type)
194 (values 'signed-byte-32 'signed-reg)
195 (values 'unsigned-byte-32 'unsigned-reg))
196 (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
198 (!def-vm-support-routine make-call-out-tns (type)
199 (declare (type alien-fun-type type))
200 (let ((arg-state (make-arg-state)))
202 (dolist (arg-type (alien-fun-type-arg-types type))
203 (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
204 (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
205 (* (arg-state-stack-frame-size arg-state) n-word-bytes)
207 (invoke-alien-type-method
209 (alien-fun-type-result-type type)
210 (make-result-state))))))
213 ;;; Sort out long longs, by splitting them up. However, need to take
214 ;;; care about register/stack alignment and whether they will fully
215 ;;; fit into registers or must go on the stack.
217 (deftransform %alien-funcall ((function type &rest args))
218 (aver (sb!c::constant-lvar-p type))
219 (let* ((type (sb!c::lvar-value type))
220 (arg-types (alien-fun-type-arg-types type))
221 (result-type (alien-fun-type-result-type type))
225 (aver (= (length arg-types) (length args)))
226 ;; We need to do something special for 64-bit integer arguments
228 (if (or (some #'(lambda (type)
229 (and (alien-integer-type-p type)
230 (> (sb!alien::alien-integer-type-bits type) 32)))
232 (and (alien-integer-type-p result-type)
233 (> (sb!alien::alien-integer-type-bits result-type) 32)))
234 (collect ((new-args) (lambda-vars) (new-arg-types))
235 (dolist (type arg-types)
236 (let ((arg (gensym)))
238 (cond ((and (alien-integer-type-p type)
239 (> (sb!alien::alien-integer-type-bits type) 32))
245 ;; Need to pad for alignment.
250 (new-arg-types (parse-alien-type
252 (sb!kernel:make-null-lexenv))))
256 (new-args `(ash ,arg -32))
257 (new-args `(logand ,arg #xffffffff))
258 (if (alien-integer-type-signed type)
259 (new-arg-types (parse-alien-type
261 (sb!kernel:make-null-lexenv)))
262 (new-arg-types (parse-alien-type
264 (sb!kernel:make-null-lexenv))))
265 (new-arg-types (parse-alien-type
267 (sb!kernel:make-null-lexenv))))
268 ((alien-integer-type-p type)
273 (new-arg-types type))
274 ((alien-single-float-type-p type)
279 (new-arg-types type))
280 ((alien-double-float-type-p type)
284 (incf stack 3) ; Doubles are aligned on
285 (incf stack 2))) ; the stack.
287 (new-arg-types type))
290 (new-arg-types type)))))
291 (cond ((and (alien-integer-type-p result-type)
292 (> (sb!alien::alien-integer-type-bits result-type) 32))
293 (let ((new-result-type
294 (let ((sb!alien::*values-type-okay* t))
296 (if (alien-integer-type-signed result-type)
297 '(values (signed 32) (unsigned 32))
298 '(values (unsigned 32) (unsigned 32)))
299 (sb!kernel:make-null-lexenv)))))
300 `(lambda (function type ,@(lambda-vars))
301 (declare (ignore type))
302 (multiple-value-bind (high low)
303 (%alien-funcall function
304 ',(make-alien-fun-type
305 :arg-types (new-arg-types)
306 :result-type new-result-type)
308 (logior low (ash high 32))))))
310 `(lambda (function type ,@(lambda-vars))
311 (declare (ignore type))
312 (%alien-funcall function
313 ',(make-alien-fun-type
314 :arg-types (new-arg-types)
315 :result-type result-type)
317 (sb!c::give-up-ir1-transform))))
320 (deftransform %alien-funcall ((function type &rest args))
321 (aver (sb!c::constant-lvar-p type))
322 (let* ((type (sb!c::lvar-value type))
323 (arg-types (alien-fun-type-arg-types type))
324 (result-type (alien-fun-type-result-type type)))
325 (aver (= (length arg-types) (length args)))
326 ;; We need to do something special for 64-bit integer arguments
328 (if (or (some #'(lambda (type)
329 (and (alien-integer-type-p type)
330 (> (sb!alien::alien-integer-type-bits type) 32)))
332 (and (alien-integer-type-p result-type)
333 (> (sb!alien::alien-integer-type-bits result-type) 32)))
334 (collect ((new-args) (lambda-vars) (new-arg-types))
335 (dolist (type arg-types)
336 (let ((arg (gensym)))
338 (cond ((and (alien-integer-type-p type)
339 (> (sb!alien::alien-integer-type-bits type) 32))
340 ;; 64-bit long long types are stored in
341 ;; consecutive locations, most significant word
342 ;; first (big-endian).
343 (new-args `(ash ,arg -32))
344 (new-args `(logand ,arg #xffffffff))
345 (if (alien-integer-type-signed type)
346 (new-arg-types (parse-alien-type '(signed 32) (sb!kernel:make-null-lexenv)))
347 (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
348 (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel:make-null-lexenv))))
351 (new-arg-types type)))))
352 (cond ((and (alien-integer-type-p result-type)
353 (> (sb!alien::alien-integer-type-bits result-type) 32))
354 (let ((new-result-type
355 (let ((sb!alien::*values-type-okay* t))
357 (if (alien-integer-type-signed result-type)
358 '(values (signed 32) (unsigned 32))
359 '(values (unsigned 32) (unsigned 32)))
360 (sb!kernel:make-null-lexenv)))))
361 `(lambda (function type ,@(lambda-vars))
362 (declare (ignore type))
363 (multiple-value-bind (high low)
364 (%alien-funcall function
365 ',(make-alien-fun-type
366 :arg-types (new-arg-types)
367 :result-type new-result-type)
369 (logior low (ash high 32))))))
371 `(lambda (function type ,@(lambda-vars))
372 (declare (ignore type))
373 (%alien-funcall function
374 ',(make-alien-fun-type
375 :arg-types (new-arg-types)
376 :result-type result-type)
378 (sb!c::give-up-ir1-transform))))
380 (define-vop (foreign-symbol-sap)
381 (:translate foreign-symbol-sap)
384 (:arg-types (:constant simple-string))
385 (:info foreign-symbol)
386 (:results (res :scs (sap-reg)))
387 (:result-types system-area-pointer)
389 (inst lr res (make-fixup foreign-symbol :foreign))))
392 (define-vop (foreign-symbol-dataref-sap)
393 (:translate foreign-symbol-dataref-sap)
396 (:arg-types (:constant simple-string))
397 (:info foreign-symbol)
398 (:results (res :scs (sap-reg)))
399 (:result-types system-area-pointer)
400 (:temporary (:scs (non-descriptor-reg)) addr)
402 (inst lr addr (make-fixup foreign-symbol :foreign-dataref))
405 (define-vop (call-out)
406 (:args (function :scs (sap-reg) :target cfunc)
408 (:results (results :more t))
409 (:ignore args results)
411 (:temporary (:sc any-reg :offset cfunc-offset
412 :from (:argument 0) :to (:result 0)) cfunc)
413 (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
414 (:temporary (:scs (non-descriptor-reg)) temp)
417 (let ((cur-nfp (current-nfp-tn vop)))
419 (store-stack-tn nfp-save cur-nfp))
420 (inst lr temp (make-fixup "call_into_c" :foreign))
422 (move cfunc function)
425 (load-stack-tn cur-nfp nfp-save)))))
428 (define-vop (alloc-number-stack-space)
430 (:results (result :scs (sap-reg any-reg)))
431 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
433 (unless (zerop amount)
434 ;; FIXME: I don't understand why we seem to be adding
435 ;; NUMBER-STACK-DISPLACEMENT twice here. Weird. -- CSR,
437 (let ((delta (- (logandc2 (+ amount number-stack-displacement
438 +stack-alignment-bytes+)
439 +stack-alignment-bytes+))))
440 (cond ((>= delta (ash -1 16))
441 (inst stwu nsp-tn nsp-tn delta))
444 (inst stwux nsp-tn nsp-tn temp)))))
445 (unless (location= result nsp-tn)
446 ;; They are only location= when the result tn was allocated by
447 ;; make-call-out-tns above, which takes the number-stack-displacement
448 ;; into account itself.
449 (inst addi result nsp-tn number-stack-displacement))))
451 (define-vop (dealloc-number-stack-space)
455 (unless (zerop amount)
456 (let ((delta (logandc2 (+ amount number-stack-displacement
457 +stack-alignment-bytes+)
458 +stack-alignment-bytes+)))
459 (cond ((< delta (ash 1 16))
460 (inst addi nsp-tn nsp-tn delta))
462 (inst lwz nsp-tn nsp-tn 0)))))))
466 (defun alien-callback-accessor-form (type sap offset)
468 (sb!alien::parse-alien-type type (sb!kernel:make-null-lexenv))))
469 (cond ((sb!alien::alien-integer-type-p parsed-type)
470 ;; Unaligned access is slower, but possible, so this is nice and
471 ;; simple. Also, we're a big-endian machine, so we need to get
472 ;; byte offsets correct.
473 (let ((bits (sb!alien::alien-type-bits parsed-type)))
475 (cond ((< bits n-word-bits)
477 (ceiling bits n-byte-bits)))
479 `(deref (sap-alien (sap+ ,sap
480 ,(+ byte-offset offset))
483 `(deref (sap-alien (sap+ ,sap ,offset) (* ,type)))))))
485 ;;; The "Mach-O Runtime Conventions" document for OS X almost
486 ;;; specifies the calling convention (it neglects to mention that
487 ;;; the linkage area is 24 bytes).
489 (defconstant n-foreign-linkage-area-bytes 24)
491 ;;; On linux only use 8 bytes for LR and Back chain. JRXR
494 (defconstant n-foreign-linkage-area-bytes 8)
496 ;;; Returns a vector in static space containing machine code for the
497 ;;; callback wrapper. Linux version. JRXR. 2006/11/13
499 (defun alien-callback-assembler-wrapper (index result-type argument-types)
501 (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n))
503 (make-random-tn :kind :normal :sc (sc-or-lose
506 (let* ((segment (make-segment)))
508 ;; Copy args from registers or stack to new position
515 (mapcar (lambda (type)
516 (ceiling (alien-type-bits type)
519 ;; Return area allocation.
521 (ceiling (or (alien-type-bits result-type) 0) n-word-bits))
522 (n-return-area-bytes (* n-return-area-words
524 ;; FIXME: magic constant, and probably n-args-bytes
525 ;; JRXR: What's this for? Copied from Darwin.
526 (args-size (* 3 n-word-bytes))
527 (frame-size (logandc2
531 SB!VM::NUMBER-STACK-DISPLACEMENT
532 +stack-alignment-bytes+)
533 +stack-alignment-bytes+))
534 (return-area-pos (- frame-size
535 SB!VM::NUMBER-STACK-DISPLACEMENT
537 (arg-store-pos (- return-area-pos
538 n-return-area-bytes))
539 (stack-pointer (make-gpr 1))
542 (in-words-processed 0)
543 (out-words-processed 0)
544 (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10)))
545 (fprs (mapcar #'make-fpr
546 '(1 2 3 4 5 6 7 8))) )
547 ;; Setup useful functions and then copy all args.
548 (flet ((load-address-into (reg addr)
549 (let ((high (ldb (byte 16 16) addr))
550 (low (ldb (byte 16 0) addr)))
552 (inst ori reg reg low)))
553 (save-arg (type words)
554 (let ((integerp (not (alien-float-type-p type)))
555 (in-offset (+ (* in-words-processed n-word-bytes)
556 n-foreign-linkage-area-bytes))
557 (out-offset (- (* out-words-processed n-word-bytes)
561 ;; Only upto long longs are passed
564 ;; And needs space for whole arg,
565 ;; including alignment.
567 (rem (length gprs) words))
571 (rem (length gprs) words))
574 (let ((gpr (pop gprs)))
575 (inst stw gpr stack-pointer
577 (incf out-words-processed)
578 (incf out-offset n-word-bytes)))
580 ;; First ensure alignment.
581 ;; FIXME! If passing structures
582 ;; becomes allowable, then this is
585 (rem in-words-processed
588 (incf in-words-processed)
592 ;; Copy from memory to memory.
593 (inst lwz r0 stack-pointer
595 (inst stw r0 stack-pointer
597 (incf out-words-processed)
598 (incf out-offset n-word-bytes)
599 (incf in-words-processed)
600 (incf in-offset n-word-bytes)))))
601 ;; The handling of floats is a little ugly
602 ;; because we hard-code the number of words
603 ;; for single- and double-floats.
604 ((alien-single-float-type-p type)
605 (let ((fpr (pop fprs)))
607 (inst stfs fpr stack-pointer out-offset)
609 ;; The ABI says that floats
610 ;; stored on the stack are
611 ;; promoted to doubles. gcc
612 ;; stores them as floats.
614 ;; => no alignment needed either.
616 stack-pointer in-offset)
618 stack-pointer out-offset)
619 (incf in-words-processed))))
620 (incf out-words-processed))
621 ((alien-double-float-type-p type)
622 (let ((fpr (pop fprs)))
624 (inst stfd fpr stack-pointer out-offset)
627 (if (oddp in-words-processed)
629 (incf in-words-processed)
630 (incf in-offset n-word-bytes)))
632 stack-pointer in-offset)
634 stack-pointer out-offset)
635 (incf in-words-processed 2))))
636 (incf out-words-processed 2))
638 (bug "Unknown alien floating point type: ~S" type))))))
641 (mapcar (lambda (arg)
642 (ceiling (alien-type-bits arg) n-word-bits))
645 ;; Arranged the args, allocated the return area. Now
646 ;; actuall call funcall3: funcall3 (call-alien-function,
647 ;; index, args, return-area)
649 (destructuring-bind (arg1 arg2 arg3 arg4)
650 (mapcar #'make-gpr '(3 4 5 6))
651 (load-address-into arg1 (+ nil-value (static-symbol-offset
652 'sb!alien::*enter-alien-callback*)))
653 (loadw arg1 arg1 symbol-value-slot other-pointer-lowtag)
654 (inst li arg2 (fixnumize index))
655 (inst addi arg3 stack-pointer (- arg-store-pos))
656 (inst addi arg4 stack-pointer (- return-area-pos)))
658 ;; Setup everything. Now save sp, setup the frame.
660 (inst stw r0 stack-pointer (* 2 n-word-bytes)) ; FIXME: magic
661 ; constant, copied from Darwin.
662 (inst stwu stack-pointer stack-pointer (- frame-size))
664 ;; And make the call.
665 (load-address-into r0 (foreign-symbol-address "funcall3"))
669 ;; We're back! Restore sp and lr, load the
670 ;; return value from just under sp, and return.
671 (inst lwz stack-pointer stack-pointer 0)
672 (inst lwz r0 stack-pointer (* 2 n-word-bytes))
675 ((sb!alien::alien-single-float-type-p result-type)
676 (let ((f1 (make-fpr 1)))
677 (inst lfs f1 stack-pointer (- return-area-pos))))
678 ((sb!alien::alien-double-float-type-p result-type)
679 (let ((f1 (make-fpr 1)))
680 (inst lfd f1 stack-pointer (- return-area-pos))))
681 ((sb!alien::alien-void-type-p result-type)
685 (loop with gprs = (mapcar #'make-gpr '(3 4))
686 repeat n-return-area-words
688 for offset from (- return-area-pos)
692 (bug "Out of return registers in alien-callback trampoline."))
693 (inst lwz gpr stack-pointer offset))))
695 (finalize-segment segment)
697 ;; Now that the segment is done, convert it to a static
698 ;; vector we can point foreign code to.
699 (let* ((buffer (sb!assem::segment-buffer segment))
700 (vector (make-static-vector (length buffer)
701 :element-type '(unsigned-byte 8)
702 :initial-contents buffer))
703 (sap (sb!sys:vector-sap vector)))
704 (sb!alien:alien-funcall
705 (sb!alien:extern-alien "ppc_flush_icache"
712 ;;; Returns a vector in static space containing machine code for the
715 (defun alien-callback-assembler-wrapper (index result-type argument-types)
717 (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n))
719 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) :offset n)))
720 (let* ((segment (make-segment)))
722 ;; To save our arguments, we follow the algorithm sketched in the
723 ;; "PowerPC Calling Conventions" section of that document.
725 ;; CLH: There are a couple problems here. First, we bail if
726 ;; we run out of registers. AIUI, we can just ignore the extra
727 ;; args here and we will be ok...
728 (let ((words-processed 0)
729 (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10)))
730 (fprs (mapcar #'make-fpr '(1 2 3 4 5 6 7 8 9 10 11 12 13)))
731 (stack-pointer (make-gpr 1)))
732 (labels ((save-arg (type words)
733 (let ((integerp (not (alien-float-type-p type)))
734 (offset (+ (* words-processed n-word-bytes)
735 n-foreign-linkage-area-bytes)))
738 (let ((gpr (pop gprs)))
740 (inst stw gpr stack-pointer offset))
741 (incf words-processed)
742 (incf offset n-word-bytes))))
743 ;; The handling of floats is a little ugly
744 ;; because we hard-code the number of words
745 ;; for single- and double-floats.
746 ((alien-single-float-type-p type)
748 (let ((fpr (pop fprs)))
750 (inst stfs fpr stack-pointer offset)))
751 (incf words-processed))
752 ((alien-double-float-type-p type)
753 (setf gprs (cddr gprs))
754 (let ((fpr (pop fprs)))
756 (inst stfd fpr stack-pointer offset)))
757 (incf words-processed 2))
759 (bug "Unknown alien floating point type: ~S" type))))))
762 (mapcar (lambda (arg)
763 (ceiling (alien-type-bits arg) n-word-bits))
765 ;; Set aside room for the return area just below sp, then
766 ;; actually call funcall3: funcall3 (call-alien-function,
767 ;; index, args, return-area)
769 ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to be
770 ;; because they're word-aligned. Kinda gross, but hey ...
771 (let* ((n-return-area-words
772 (ceiling (or (alien-type-bits result-type) 0) n-word-bits))
773 (n-return-area-bytes (* n-return-area-words n-word-bytes))
774 ;; FIXME: magic constant, and probably n-args-bytes
775 (args-size (* 3 n-word-bytes))
776 ;; FIXME: n-frame-bytes?
777 (frame-size (logandc2 (+ n-foreign-linkage-area-bytes
780 +stack-alignment-bytes+)
781 +stack-alignment-bytes+)))
782 (destructuring-bind (sp r0 arg1 arg2 arg3 arg4)
783 (mapcar #'make-gpr '(1 0 3 4 5 6))
784 ;; FIXME: This is essentially the same code as LR in
785 ;; insts.lisp, but attempting to use (INST LR ...) instead
786 ;; of this function results in callbacks not working. Why?
788 (flet ((load-address-into (reg addr)
789 (let ((high (ldb (byte 16 16) addr))
790 (low (ldb (byte 16 0) addr)))
792 (inst ori reg reg low))))
795 ;; CLH 2006/02/10 -Following JES' logic in
796 ;; x86-64/c-call.lisp, we need to access
797 ;; ENTER-ALIEN-CALLBACK through the symbol-value slot
798 ;; of SB-ALIEN::*ENTER-ALIEN-CALLBACK* to ensure that
799 ;; it works if GC moves ENTER-ALIEN-CALLBACK.
802 ;; (load-address-into arg1 (get-lisp-obj-address #'enter-alien-callback))
805 ;; (load-symbol arg1 'sb!alien::*enter-alien-callback*)
807 ;; whoops: can't use load-symbol here as null-tn might
808 ;; not be loaded with the proper value as we are
809 ;; coming in from C code. Use nil-value constant
810 ;; instead, following the logic in x86-64/c-call.lisp.
811 (load-address-into arg1 (+ nil-value (static-symbol-offset
812 'sb!alien::*enter-alien-callback*)))
813 (loadw arg1 arg1 symbol-value-slot other-pointer-lowtag)
815 (inst li arg2 (fixnumize index))
816 (inst addi arg3 sp n-foreign-linkage-area-bytes)
817 ;; FIXME: This was (- (* RETURN-AREA-SIZE N-WORD-BYTES)), while
818 ;; RETURN-AREA-SIZE was (* N-RETURN-AREA-WORDS N-WORD-BYTES):
819 ;; I assume the intention was (- N-RETURN-AREA-BYTES), but who knows?
821 (inst addi arg4 sp (- n-return-area-bytes))
822 ;; FIXME! FIXME FIXME: What does this FIXME refer to?
823 ;; Save sp, setup the frame
825 (inst stw r0 sp (* 2 n-word-bytes)) ; FIXME: magic constant
826 (inst stwu sp sp (- frame-size))
828 (load-address-into r0 (foreign-symbol-address "funcall3"))
831 ;; We're back! Restore sp and lr, load the return value from just
832 ;; under sp, and return.
834 (inst lwz r0 sp (* 2 n-word-bytes))
837 ((sb!alien::alien-single-float-type-p result-type)
838 (let ((f1 (make-fpr 1)))
839 (inst lfs f1 sp (- (* n-return-area-words n-word-bytes)))))
840 ((sb!alien::alien-double-float-type-p result-type)
841 (let ((f1 (make-fpr 1)))
842 (inst lfd f1 sp (- (* n-return-area-words n-word-bytes)))))
843 ((sb!alien::alien-void-type-p result-type)
847 (loop with gprs = (mapcar #'make-gpr '(3 4))
848 repeat n-return-area-words
850 for offset from (- (* n-return-area-words n-word-bytes))
854 (bug "Out of return registers in alien-callback trampoline."))
855 (inst lwz gpr sp offset))))
857 (finalize-segment segment)
858 ;; Now that the segment is done, convert it to a static
859 ;; vector we can point foreign code to.
860 (let* ((buffer (sb!assem::segment-buffer segment))
861 (vector (make-static-vector (length buffer)
862 :element-type '(unsigned-byte 8)
863 :initial-contents buffer))
864 (sap (sb!sys:vector-sap vector)))
865 (sb!alien:alien-funcall
866 (sb!alien:extern-alien "ppc_flush_icache"