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 (:result-types system-area-pointer)
432 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
434 (unless (zerop amount)
435 ;; FIXME: I don't understand why we seem to be adding
436 ;; NUMBER-STACK-DISPLACEMENT twice here. Weird. -- CSR,
438 (let ((delta (- (logandc2 (+ amount number-stack-displacement
439 +stack-alignment-bytes+)
440 +stack-alignment-bytes+))))
441 (cond ((>= delta (ash -1 16))
442 (inst stwu nsp-tn nsp-tn delta))
445 (inst stwux nsp-tn nsp-tn temp)))))
446 (unless (location= result nsp-tn)
447 ;; They are only location= when the result tn was allocated by
448 ;; make-call-out-tns above, which takes the number-stack-displacement
449 ;; into account itself.
450 (inst addi result nsp-tn number-stack-displacement))))
452 (define-vop (dealloc-number-stack-space)
456 (unless (zerop amount)
457 (let ((delta (logandc2 (+ amount number-stack-displacement
458 +stack-alignment-bytes+)
459 +stack-alignment-bytes+)))
460 (cond ((< delta (ash 1 16))
461 (inst addi nsp-tn nsp-tn delta))
463 (inst lwz nsp-tn nsp-tn 0)))))))
467 (defun alien-callback-accessor-form (type sap offset)
469 (sb!alien::parse-alien-type type (sb!kernel:make-null-lexenv))))
470 (cond ((sb!alien::alien-integer-type-p parsed-type)
471 ;; Unaligned access is slower, but possible, so this is nice and
472 ;; simple. Also, we're a big-endian machine, so we need to get
473 ;; byte offsets correct.
474 (let ((bits (sb!alien::alien-type-bits parsed-type)))
476 (cond ((< bits n-word-bits)
478 (ceiling bits n-byte-bits)))
480 `(deref (sap-alien (sap+ ,sap
481 ,(+ byte-offset offset))
484 `(deref (sap-alien (sap+ ,sap ,offset) (* ,type)))))))
486 ;;; The "Mach-O Runtime Conventions" document for OS X almost
487 ;;; specifies the calling convention (it neglects to mention that
488 ;;; the linkage area is 24 bytes).
490 (defconstant n-foreign-linkage-area-bytes 24)
492 ;;; On linux only use 8 bytes for LR and Back chain. JRXR
495 (defconstant n-foreign-linkage-area-bytes 8)
497 ;;; Returns a vector in static space containing machine code for the
498 ;;; callback wrapper. Linux version. JRXR. 2006/11/13
500 (defun alien-callback-assembler-wrapper (index result-type argument-types)
502 (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n))
504 (make-random-tn :kind :normal :sc (sc-or-lose
507 (let* ((segment (make-segment)))
509 ;; Copy args from registers or stack to new position
516 (mapcar (lambda (type)
517 (ceiling (alien-type-bits type)
520 ;; Return area allocation.
522 (ceiling (or (alien-type-bits result-type) 0) n-word-bits))
523 (n-return-area-bytes (* n-return-area-words
525 ;; FIXME: magic constant, and probably n-args-bytes
526 ;; JRXR: What's this for? Copied from Darwin.
527 (args-size (* 3 n-word-bytes))
528 (frame-size (logandc2
532 SB!VM::NUMBER-STACK-DISPLACEMENT
533 +stack-alignment-bytes+)
534 +stack-alignment-bytes+))
535 (return-area-pos (- frame-size
536 SB!VM::NUMBER-STACK-DISPLACEMENT
538 (arg-store-pos (- return-area-pos
539 n-return-area-bytes))
540 (stack-pointer (make-gpr 1))
543 (in-words-processed 0)
544 (out-words-processed 0)
545 (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10)))
546 (fprs (mapcar #'make-fpr
547 '(1 2 3 4 5 6 7 8))) )
548 ;; Setup useful functions and then copy all args.
549 (flet ((load-address-into (reg addr)
550 (let ((high (ldb (byte 16 16) addr))
551 (low (ldb (byte 16 0) addr)))
553 (inst ori reg reg low)))
554 (save-arg (type words)
555 (let ((integerp (not (alien-float-type-p type)))
556 (in-offset (+ (* in-words-processed n-word-bytes)
557 n-foreign-linkage-area-bytes))
558 (out-offset (- (* out-words-processed n-word-bytes)
562 ;; Only upto long longs are passed
565 ;; And needs space for whole arg,
566 ;; including alignment.
568 (rem (length gprs) words))
572 (rem (length gprs) words))
575 (let ((gpr (pop gprs)))
576 (inst stw gpr stack-pointer
578 (incf out-words-processed)
579 (incf out-offset n-word-bytes)))
581 ;; First ensure alignment.
582 ;; FIXME! If passing structures
583 ;; becomes allowable, then this is
586 (rem in-words-processed
589 (incf in-words-processed)
593 ;; Copy from memory to memory.
594 (inst lwz r0 stack-pointer
596 (inst stw r0 stack-pointer
598 (incf out-words-processed)
599 (incf out-offset n-word-bytes)
600 (incf in-words-processed)
601 (incf in-offset n-word-bytes)))))
602 ;; The handling of floats is a little ugly
603 ;; because we hard-code the number of words
604 ;; for single- and double-floats.
605 ((alien-single-float-type-p type)
606 (let ((fpr (pop fprs)))
608 (inst stfs fpr stack-pointer out-offset)
610 ;; The ABI says that floats
611 ;; stored on the stack are
612 ;; promoted to doubles. gcc
613 ;; stores them as floats.
615 ;; => no alignment needed either.
617 stack-pointer in-offset)
619 stack-pointer out-offset)
620 (incf in-words-processed))))
621 (incf out-words-processed))
622 ((alien-double-float-type-p type)
623 (let ((fpr (pop fprs)))
625 (inst stfd fpr stack-pointer out-offset)
628 (if (oddp in-words-processed)
630 (incf in-words-processed)
631 (incf in-offset n-word-bytes)))
633 stack-pointer in-offset)
635 stack-pointer out-offset)
636 (incf in-words-processed 2))))
637 (incf out-words-processed 2))
639 (bug "Unknown alien floating point type: ~S" type))))))
642 (mapcar (lambda (arg)
643 (ceiling (alien-type-bits arg) n-word-bits))
646 ;; Arranged the args, allocated the return area. Now
647 ;; actuall call funcall3: funcall3 (call-alien-function,
648 ;; index, args, return-area)
650 (destructuring-bind (arg1 arg2 arg3 arg4)
651 (mapcar #'make-gpr '(3 4 5 6))
652 (load-address-into arg1 (+ nil-value (static-symbol-offset
653 'sb!alien::*enter-alien-callback*)))
654 (loadw arg1 arg1 symbol-value-slot other-pointer-lowtag)
655 (inst li arg2 (fixnumize index))
656 (inst addi arg3 stack-pointer (- arg-store-pos))
657 (inst addi arg4 stack-pointer (- return-area-pos)))
659 ;; Setup everything. Now save sp, setup the frame.
661 (inst stw r0 stack-pointer (* 2 n-word-bytes)) ; FIXME: magic
662 ; constant, copied from Darwin.
663 (inst stwu stack-pointer stack-pointer (- frame-size))
665 ;; And make the call.
666 (load-address-into r0 (foreign-symbol-address "funcall3"))
670 ;; We're back! Restore sp and lr, load the
671 ;; return value from just under sp, and return.
672 (inst lwz stack-pointer stack-pointer 0)
673 (inst lwz r0 stack-pointer (* 2 n-word-bytes))
676 ((sb!alien::alien-single-float-type-p result-type)
677 (let ((f1 (make-fpr 1)))
678 (inst lfs f1 stack-pointer (- return-area-pos))))
679 ((sb!alien::alien-double-float-type-p result-type)
680 (let ((f1 (make-fpr 1)))
681 (inst lfd f1 stack-pointer (- return-area-pos))))
682 ((sb!alien::alien-void-type-p result-type)
686 (loop with gprs = (mapcar #'make-gpr '(3 4))
687 repeat n-return-area-words
689 for offset from (- return-area-pos)
693 (bug "Out of return registers in alien-callback trampoline."))
694 (inst lwz gpr stack-pointer offset))))
696 (finalize-segment segment)
698 ;; Now that the segment is done, convert it to a static
699 ;; vector we can point foreign code to.
700 (let* ((buffer (sb!assem::segment-buffer segment))
701 (vector (make-static-vector (length buffer)
702 :element-type '(unsigned-byte 8)
703 :initial-contents buffer))
704 (sap (sb!sys:vector-sap vector)))
705 (sb!alien:alien-funcall
706 (sb!alien:extern-alien "ppc_flush_icache"
713 ;;; Returns a vector in static space containing machine code for the
716 (defun alien-callback-assembler-wrapper (index result-type argument-types)
718 (make-random-tn :kind :normal :sc (sc-or-lose 'any-reg) :offset n))
720 (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg) :offset n)))
721 (let* ((segment (make-segment)))
723 ;; To save our arguments, we follow the algorithm sketched in the
724 ;; "PowerPC Calling Conventions" section of that document.
726 ;; CLH: There are a couple problems here. First, we bail if
727 ;; we run out of registers. AIUI, we can just ignore the extra
728 ;; args here and we will be ok...
729 (let ((words-processed 0)
730 (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10)))
731 (fprs (mapcar #'make-fpr '(1 2 3 4 5 6 7 8 9 10 11 12 13)))
732 (stack-pointer (make-gpr 1)))
733 (labels ((save-arg (type words)
734 (let ((integerp (not (alien-float-type-p type)))
735 (offset (+ (* words-processed n-word-bytes)
736 n-foreign-linkage-area-bytes)))
739 (let ((gpr (pop gprs)))
741 (inst stw gpr stack-pointer offset))
742 (incf words-processed)
743 (incf offset n-word-bytes))))
744 ;; The handling of floats is a little ugly
745 ;; because we hard-code the number of words
746 ;; for single- and double-floats.
747 ((alien-single-float-type-p type)
749 (let ((fpr (pop fprs)))
751 (inst stfs fpr stack-pointer offset)))
752 (incf words-processed))
753 ((alien-double-float-type-p type)
754 (setf gprs (cddr gprs))
755 (let ((fpr (pop fprs)))
757 (inst stfd fpr stack-pointer offset)))
758 (incf words-processed 2))
760 (bug "Unknown alien floating point type: ~S" type))))))
763 (mapcar (lambda (arg)
764 (ceiling (alien-type-bits arg) n-word-bits))
766 ;; Set aside room for the return area just below sp, then
767 ;; actually call funcall3: funcall3 (call-alien-function,
768 ;; index, args, return-area)
770 ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to be
771 ;; because they're word-aligned. Kinda gross, but hey ...
772 (let* ((n-return-area-words
773 (ceiling (or (alien-type-bits result-type) 0) n-word-bits))
774 (n-return-area-bytes (* n-return-area-words n-word-bytes))
775 ;; FIXME: magic constant, and probably n-args-bytes
776 (args-size (* 3 n-word-bytes))
777 ;; FIXME: n-frame-bytes?
778 (frame-size (logandc2 (+ n-foreign-linkage-area-bytes
781 +stack-alignment-bytes+)
782 +stack-alignment-bytes+)))
783 (destructuring-bind (sp r0 arg1 arg2 arg3 arg4)
784 (mapcar #'make-gpr '(1 0 3 4 5 6))
785 ;; FIXME: This is essentially the same code as LR in
786 ;; insts.lisp, but attempting to use (INST LR ...) instead
787 ;; of this function results in callbacks not working. Why?
789 (flet ((load-address-into (reg addr)
790 (let ((high (ldb (byte 16 16) addr))
791 (low (ldb (byte 16 0) addr)))
793 (inst ori reg reg low))))
796 ;; CLH 2006/02/10 -Following JES' logic in
797 ;; x86-64/c-call.lisp, we need to access
798 ;; ENTER-ALIEN-CALLBACK through the symbol-value slot
799 ;; of SB-ALIEN::*ENTER-ALIEN-CALLBACK* to ensure that
800 ;; it works if GC moves ENTER-ALIEN-CALLBACK.
803 ;; (load-address-into arg1 (get-lisp-obj-address #'enter-alien-callback))
806 ;; (load-symbol arg1 'sb!alien::*enter-alien-callback*)
808 ;; whoops: can't use load-symbol here as null-tn might
809 ;; not be loaded with the proper value as we are
810 ;; coming in from C code. Use nil-value constant
811 ;; instead, following the logic in x86-64/c-call.lisp.
812 (load-address-into arg1 (+ nil-value (static-symbol-offset
813 'sb!alien::*enter-alien-callback*)))
814 (loadw arg1 arg1 symbol-value-slot other-pointer-lowtag)
816 (inst li arg2 (fixnumize index))
817 (inst addi arg3 sp n-foreign-linkage-area-bytes)
818 ;; FIXME: This was (- (* RETURN-AREA-SIZE N-WORD-BYTES)), while
819 ;; RETURN-AREA-SIZE was (* N-RETURN-AREA-WORDS N-WORD-BYTES):
820 ;; I assume the intention was (- N-RETURN-AREA-BYTES), but who knows?
822 (inst addi arg4 sp (- n-return-area-bytes))
823 ;; FIXME! FIXME FIXME: What does this FIXME refer to?
824 ;; Save sp, setup the frame
826 (inst stw r0 sp (* 2 n-word-bytes)) ; FIXME: magic constant
827 (inst stwu sp sp (- frame-size))
829 (load-address-into r0 (foreign-symbol-address "funcall3"))
832 ;; We're back! Restore sp and lr, load the return value from just
833 ;; under sp, and return.
835 (inst lwz r0 sp (* 2 n-word-bytes))
838 ((sb!alien::alien-single-float-type-p result-type)
839 (let ((f1 (make-fpr 1)))
840 (inst lfs f1 sp (- (* n-return-area-words n-word-bytes)))))
841 ((sb!alien::alien-double-float-type-p result-type)
842 (let ((f1 (make-fpr 1)))
843 (inst lfd f1 sp (- (* n-return-area-words n-word-bytes)))))
844 ((sb!alien::alien-void-type-p result-type)
848 (loop with gprs = (mapcar #'make-gpr '(3 4))
849 repeat n-return-area-words
851 for offset from (- (* n-return-area-words n-word-bytes))
855 (bug "Out of return registers in alien-callback trampoline."))
856 (inst lwz gpr sp offset))))
858 (finalize-segment segment)
859 ;; Now that the segment is done, convert it to a static
860 ;; vector we can point foreign code to.
861 (let* ((buffer (sb!assem::segment-buffer segment))
862 (vector (make-static-vector (length buffer)
863 :element-type '(unsigned-byte 8)
864 :initial-contents buffer))
865 (sap (sb!sys:vector-sap vector)))
866 (sb!alien:alien-funcall
867 (sb!alien:extern-alien "ppc_flush_icache"