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 (defun 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
251 '(unsigned 32) nil
)))
255 (new-args `(ash ,arg -
32))
256 (new-args `(logand ,arg
#xffffffff
))
257 (if (alien-integer-type-signed type
)
258 (new-arg-types (parse-alien-type
260 (new-arg-types (parse-alien-type
261 '(unsigned 32) nil
)))
262 (new-arg-types (parse-alien-type
263 '(unsigned 32) nil
)))
264 ((alien-single-float-type-p type
)
269 (new-arg-types type
))
270 ((alien-double-float-type-p type
)
274 (incf stack
3) ; Doubles are aligned on
275 (incf stack
2))) ; the stack.
277 (new-arg-types type
))
283 (new-arg-types type
)))))
284 (cond ((and (alien-integer-type-p result-type
)
285 (> (sb!alien
::alien-integer-type-bits result-type
) 32))
286 (let ((new-result-type
287 (let ((sb!alien
::*values-type-okay
* t
))
289 (if (alien-integer-type-signed result-type
)
290 '(values (signed 32) (unsigned 32))
291 '(values (unsigned 32) (unsigned 32)))
293 `(lambda (function type
,@(lambda-vars))
294 (declare (ignore type
))
295 (multiple-value-bind (high low
)
296 (%alien-funcall function
297 ',(make-alien-fun-type
298 :arg-types
(new-arg-types)
299 :result-type new-result-type
)
301 (logior low
(ash high
32))))))
303 `(lambda (function type
,@(lambda-vars))
304 (declare (ignore type
))
305 (%alien-funcall function
306 ',(make-alien-fun-type
307 :arg-types
(new-arg-types)
308 :result-type result-type
)
310 (sb!c
::give-up-ir1-transform
))))
313 (deftransform %alien-funcall
((function type
&rest args
))
314 (aver (sb!c
::constant-lvar-p type
))
315 (let* ((type (sb!c
::lvar-value type
))
316 (arg-types (alien-fun-type-arg-types type
))
317 (result-type (alien-fun-type-result-type type
)))
318 (aver (= (length arg-types
) (length args
)))
319 ;; We need to do something special for 64-bit integer arguments
321 (if (or (some #'(lambda (type)
322 (and (alien-integer-type-p type
)
323 (> (sb!alien
::alien-integer-type-bits type
) 32)))
325 (and (alien-integer-type-p result-type
)
326 (> (sb!alien
::alien-integer-type-bits result-type
) 32)))
327 (collect ((new-args) (lambda-vars) (new-arg-types))
328 (dolist (type arg-types
)
329 (let ((arg (gensym)))
331 (cond ((and (alien-integer-type-p type
)
332 (> (sb!alien
::alien-integer-type-bits type
) 32))
333 ;; 64-bit long long types are stored in
334 ;; consecutive locations, most significant word
335 ;; first (big-endian).
336 (new-args `(ash ,arg -
32))
337 (new-args `(logand ,arg
#xffffffff
))
338 (if (alien-integer-type-signed type
)
339 (new-arg-types (parse-alien-type '(signed 32) nil
))
340 (new-arg-types (parse-alien-type '(unsigned 32) nil
)))
341 (new-arg-types (parse-alien-type '(unsigned 32) nil
)))
344 (new-arg-types type
)))))
345 (cond ((and (alien-integer-type-p result-type
)
346 (> (sb!alien
::alien-integer-type-bits result-type
) 32))
347 (let ((new-result-type
348 (let ((sb!alien
::*values-type-okay
* t
))
350 (if (alien-integer-type-signed result-type
)
351 '(values (signed 32) (unsigned 32))
352 '(values (unsigned 32) (unsigned 32)))
354 `(lambda (function type
,@(lambda-vars))
355 (declare (ignore type
))
356 (multiple-value-bind (high low
)
357 (%alien-funcall function
358 ',(make-alien-fun-type
359 :arg-types
(new-arg-types)
360 :result-type new-result-type
)
362 (logior low
(ash high
32))))))
364 `(lambda (function type
,@(lambda-vars))
365 (declare (ignore type
))
366 (%alien-funcall function
367 ',(make-alien-fun-type
368 :arg-types
(new-arg-types)
369 :result-type result-type
)
371 (sb!c
::give-up-ir1-transform
))))
373 (define-vop (foreign-symbol-sap)
374 (:translate foreign-symbol-sap
)
377 (:arg-types
(:constant simple-string
))
378 (:info foreign-symbol
)
379 (:results
(res :scs
(sap-reg)))
380 (:result-types system-area-pointer
)
382 (inst lr res
(make-fixup foreign-symbol
:foreign
))))
385 (define-vop (foreign-symbol-dataref-sap)
386 (:translate foreign-symbol-dataref-sap
)
389 (:arg-types
(:constant simple-string
))
390 (:info foreign-symbol
)
391 (:results
(res :scs
(sap-reg)))
392 (:result-types system-area-pointer
)
393 (:temporary
(:scs
(non-descriptor-reg)) addr
)
395 (inst lr addr
(make-fixup foreign-symbol
:foreign-dataref
))
398 (define-vop (call-out)
399 (:args
(function :scs
(sap-reg) :target cfunc
)
401 (:results
(results :more t
))
402 (:ignore args results
)
404 (:temporary
(:sc any-reg
:offset cfunc-offset
405 :from
(:argument
0) :to
(:result
0)) cfunc
)
406 (:temporary
(:sc control-stack
:offset nfp-save-offset
) nfp-save
)
407 (:temporary
(:scs
(non-descriptor-reg)) temp
)
410 (let ((cur-nfp (current-nfp-tn vop
)))
412 (store-stack-tn nfp-save cur-nfp
))
413 (inst lr temp
(make-fixup "call_into_c" :foreign
))
415 (move cfunc function
)
418 (load-stack-tn cur-nfp nfp-save
)))))
421 (define-vop (alloc-number-stack-space)
423 (:results
(result :scs
(sap-reg any-reg
)))
424 (:result-types system-area-pointer
)
425 (:temporary
(:scs
(unsigned-reg) :to
(:result
0)) temp
)
427 (unless (zerop amount
)
428 ;; FIXME: I don't understand why we seem to be adding
429 ;; NUMBER-STACK-DISPLACEMENT twice here. Weird. -- CSR,
431 (let ((delta (- (logandc2 (+ amount number-stack-displacement
432 +stack-alignment-bytes
+)
433 +stack-alignment-bytes
+))))
434 (cond ((>= delta
(ash -
1 16))
435 (inst stwu nsp-tn nsp-tn delta
))
438 (inst stwux nsp-tn nsp-tn temp
)))))
439 (unless (location= result nsp-tn
)
440 ;; They are only location= when the result tn was allocated by
441 ;; make-call-out-tns above, which takes the number-stack-displacement
442 ;; into account itself.
443 (inst addi result nsp-tn number-stack-displacement
))))
445 (define-vop (dealloc-number-stack-space)
449 (unless (zerop amount
)
450 (let ((delta (logandc2 (+ amount number-stack-displacement
451 +stack-alignment-bytes
+)
452 +stack-alignment-bytes
+)))
453 (cond ((< delta
(ash 1 16))
454 (inst addi nsp-tn nsp-tn delta
))
456 (inst lwz nsp-tn nsp-tn
0)))))))
460 (defun alien-callback-accessor-form (type sap offset
)
461 (let ((parsed-type (parse-alien-type type nil
)))
462 (cond ((sb!alien
::alien-integer-type-p parsed-type
)
463 ;; Unaligned access is slower, but possible, so this is nice and
464 ;; simple. Also, we're a big-endian machine, so we need to get
465 ;; byte offsets correct.
466 (let ((bits (sb!alien
::alien-type-bits parsed-type
)))
468 (cond ((< bits n-word-bits
)
470 (ceiling bits n-byte-bits
)))
472 `(deref (sap-alien (sap+ ,sap
473 ,(+ byte-offset offset
))
476 `(deref (sap-alien (sap+ ,sap
,offset
) (* ,type
)))))))
478 ;;; The "Mach-O Runtime Conventions" document for OS X almost
479 ;;; specifies the calling convention (it neglects to mention that
480 ;;; the linkage area is 24 bytes).
482 (defconstant n-foreign-linkage-area-bytes
24)
484 ;;; On linux only use 8 bytes for LR and Back chain. JRXR
487 (defconstant n-foreign-linkage-area-bytes
8)
489 ;;; Returns a vector in static space containing machine code for the
490 ;;; callback wrapper. Linux version. JRXR. 2006/11/13
492 (defun alien-callback-assembler-wrapper (index result-type argument-types
)
494 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'any-reg
) :offset n
))
496 (make-random-tn :kind
:normal
:sc
(sc-or-lose
499 (let* ((segment (make-segment)))
501 ;; Copy args from registers or stack to new position
508 (mapcar (lambda (type)
509 (ceiling (alien-type-bits type
)
512 ;; Return area allocation.
514 (ceiling (or (alien-type-bits result-type
) 0) n-word-bits
))
515 (n-return-area-bytes (* n-return-area-words
517 ;; FIXME: magic constant, and probably n-args-bytes
518 ;; JRXR: What's this for? Copied from Darwin.
519 (args-size (* 3 n-word-bytes
))
520 (frame-size (logandc2
524 number-stack-displacement
525 +stack-alignment-bytes
+)
526 +stack-alignment-bytes
+))
527 (return-area-pos (- frame-size
528 number-stack-displacement
530 (arg-store-pos (- return-area-pos
531 n-return-area-bytes
))
532 (stack-pointer (make-gpr 1))
535 (in-words-processed 0)
536 (out-words-processed 0)
537 (gprs (mapcar #'make-gpr
'(3 4 5 6 7 8 9 10)))
538 (fprs (mapcar #'make-fpr
539 '(1 2 3 4 5 6 7 8))) )
540 ;; Setup useful functions and then copy all args.
541 (flet ((load-address-into (reg addr
)
542 (let ((high (ldb (byte 16 16) addr
))
543 (low (ldb (byte 16 0) addr
)))
545 (inst ori reg reg low
)))
546 (save-arg (type words
)
547 (let ((integerp (not (alien-float-type-p type
)))
548 (in-offset (+ (* in-words-processed n-word-bytes
)
549 n-foreign-linkage-area-bytes
))
550 (out-offset (- (* out-words-processed n-word-bytes
)
554 ;; Only upto long longs are passed
557 ;; And needs space for whole arg,
558 ;; including alignment.
560 (rem (length gprs
) words
))
564 (rem (length gprs
) words
))
567 (let ((gpr (pop gprs
)))
568 (inst stw gpr stack-pointer
570 (incf out-words-processed
)
571 (incf out-offset n-word-bytes
)))
573 ;; First ensure alignment.
574 ;; FIXME! If passing structures
575 ;; becomes allowable, then this is
578 (rem in-words-processed
581 (incf in-words-processed
)
585 ;; Copy from memory to memory.
586 (inst lwz r0 stack-pointer
588 (inst stw r0 stack-pointer
590 (incf out-words-processed
)
591 (incf out-offset n-word-bytes
)
592 (incf in-words-processed
)
593 (incf in-offset n-word-bytes
)))))
594 ;; The handling of floats is a little ugly
595 ;; because we hard-code the number of words
596 ;; for single- and double-floats.
597 ((alien-single-float-type-p type
)
598 (let ((fpr (pop fprs
)))
600 (inst stfs fpr stack-pointer out-offset
)
602 ;; The ABI says that floats
603 ;; stored on the stack are
604 ;; promoted to doubles. gcc
605 ;; stores them as floats.
607 ;; => no alignment needed either.
609 stack-pointer in-offset
)
611 stack-pointer out-offset
)
612 (incf in-words-processed
))))
613 (incf out-words-processed
))
614 ((alien-double-float-type-p type
)
615 (let ((fpr (pop fprs
)))
617 (inst stfd fpr stack-pointer out-offset
)
620 (if (oddp in-words-processed
)
622 (incf in-words-processed
)
623 (incf in-offset n-word-bytes
)))
625 stack-pointer in-offset
)
627 stack-pointer out-offset
)
628 (incf in-words-processed
2))))
629 (incf out-words-processed
2))
631 (bug "Unknown alien floating point type: ~S" type
))))))
634 (mapcar (lambda (arg)
635 (ceiling (alien-type-bits arg
) n-word-bits
))
638 ;; Arranged the args, allocated the return area. Now
639 ;; actuall call funcall3: funcall3 (call-alien-function,
640 ;; index, args, return-area)
642 (destructuring-bind (arg1 arg2 arg3 arg4
)
643 (mapcar #'make-gpr
'(3 4 5 6))
644 (load-address-into arg1
(+ nil-value
(static-symbol-offset
645 'sb
!alien
::*enter-alien-callback
*)))
646 (loadw arg1 arg1 symbol-value-slot other-pointer-lowtag
)
647 (inst li arg2
(fixnumize index
))
648 (inst addi arg3 stack-pointer
(- arg-store-pos
))
649 (inst addi arg4 stack-pointer
(- return-area-pos
)))
651 ;; Setup everything. Now save sp, setup the frame.
653 (inst stw r0 stack-pointer
(* 2 n-word-bytes
)) ; FIXME: magic
654 ; constant, copied from Darwin.
655 (inst stwu stack-pointer stack-pointer
(- frame-size
))
657 ;; And make the call.
660 (foreign-symbol-address
661 #!-sb-thread
"funcall3"
662 #!+sb-thread
"callback_wrapper_trampoline"))
666 ;; We're back! Restore sp and lr, load the
667 ;; return value from just under sp, and return.
668 (inst lwz stack-pointer stack-pointer
0)
669 (inst lwz r0 stack-pointer
(* 2 n-word-bytes
))
672 ((sb!alien
::alien-single-float-type-p result-type
)
673 (let ((f1 (make-fpr 1)))
674 (inst lfs f1 stack-pointer
(- return-area-pos
))))
675 ((sb!alien
::alien-double-float-type-p result-type
)
676 (let ((f1 (make-fpr 1)))
677 (inst lfd f1 stack-pointer
(- return-area-pos
))))
678 ((sb!alien
::alien-void-type-p result-type
)
682 (loop with gprs
= (mapcar #'make-gpr
'(3 4))
683 repeat n-return-area-words
685 for offset from
(- return-area-pos
)
689 (bug "Out of return registers in alien-callback trampoline."))
690 (inst lwz gpr stack-pointer offset
))))
692 (finalize-segment segment
)
694 ;; Now that the segment is done, convert it to a static
695 ;; vector we can point foreign code to.
696 (let* ((buffer (sb!assem
::segment-buffer segment
))
697 (vector (make-static-vector (length buffer
)
698 :element-type
'(unsigned-byte 8)
699 :initial-contents buffer
))
700 (sap (vector-sap vector
)))
702 (extern-alien "ppc_flush_icache"
709 ;;; Returns a vector in static space containing machine code for the
712 (defun alien-callback-assembler-wrapper (index result-type argument-types
)
714 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'any-reg
) :offset n
))
716 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'double-reg
) :offset n
)))
717 (let* ((segment (make-segment)))
719 ;; To save our arguments, we follow the algorithm sketched in the
720 ;; "PowerPC Calling Conventions" section of that document.
722 ;; CLH: There are a couple problems here. First, we bail if
723 ;; we run out of registers. AIUI, we can just ignore the extra
724 ;; args here and we will be ok...
725 (let ((words-processed 0)
726 (gprs (mapcar #'make-gpr
'(3 4 5 6 7 8 9 10)))
727 (fprs (mapcar #'make-fpr
'(1 2 3 4 5 6 7 8 9 10 11 12 13)))
728 (stack-pointer (make-gpr 1)))
729 (labels ((save-arg (type words
)
730 (let ((integerp (not (alien-float-type-p type
)))
731 (offset (+ (* words-processed n-word-bytes
)
732 n-foreign-linkage-area-bytes
)))
735 (let ((gpr (pop gprs
)))
737 (inst stw gpr stack-pointer offset
))
738 (incf words-processed
)
739 (incf offset n-word-bytes
))))
740 ;; The handling of floats is a little ugly
741 ;; because we hard-code the number of words
742 ;; for single- and double-floats.
743 ((alien-single-float-type-p type
)
745 (let ((fpr (pop fprs
)))
747 (inst stfs fpr stack-pointer offset
)))
748 (incf words-processed
))
749 ((alien-double-float-type-p type
)
750 (setf gprs
(cddr gprs
))
751 (let ((fpr (pop fprs
)))
753 (inst stfd fpr stack-pointer offset
)))
754 (incf words-processed
2))
756 (bug "Unknown alien floating point type: ~S" type
))))))
759 (mapcar (lambda (arg)
760 (ceiling (alien-type-bits arg
) n-word-bits
))
762 ;; Set aside room for the return area just below sp, then
763 ;; actually call funcall3: funcall3 (call-alien-function,
764 ;; index, args, return-area)
766 ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to be
767 ;; because they're word-aligned. Kinda gross, but hey ...
768 (let* ((n-return-area-words
769 (ceiling (or (alien-type-bits result-type
) 0) n-word-bits
))
770 (n-return-area-bytes (* n-return-area-words n-word-bytes
))
771 ;; FIXME: magic constant, and probably n-args-bytes
772 (args-size (* 3 n-word-bytes
))
773 ;; FIXME: n-frame-bytes?
774 (frame-size (logandc2 (+ n-foreign-linkage-area-bytes
777 +stack-alignment-bytes
+)
778 +stack-alignment-bytes
+)))
779 (destructuring-bind (sp r0 arg1 arg2 arg3 arg4
)
780 (mapcar #'make-gpr
'(1 0 3 4 5 6))
781 ;; FIXME: This is essentially the same code as LR in
782 ;; insts.lisp, but attempting to use (INST LR ...) instead
783 ;; of this function results in callbacks not working. Why?
785 (flet ((load-address-into (reg addr
)
786 (let ((high (ldb (byte 16 16) addr
))
787 (low (ldb (byte 16 0) addr
)))
789 (inst ori reg reg low
))))
792 ;; CLH 2006/02/10 -Following JES' logic in
793 ;; x86-64/c-call.lisp, we need to access
794 ;; ENTER-ALIEN-CALLBACK through the symbol-value slot
795 ;; of SB-ALIEN::*ENTER-ALIEN-CALLBACK* to ensure that
796 ;; it works if GC moves ENTER-ALIEN-CALLBACK.
799 ;; (load-address-into arg1 (get-lisp-obj-address #'enter-alien-callback))
802 ;; (load-symbol arg1 'sb!alien::*enter-alien-callback*)
804 ;; whoops: can't use load-symbol here as null-tn might
805 ;; not be loaded with the proper value as we are
806 ;; coming in from C code. Use nil-value constant
807 ;; instead, following the logic in x86-64/c-call.lisp.
808 (load-address-into arg1
(+ nil-value
(static-symbol-offset
809 'sb
!alien
::*enter-alien-callback
*)))
810 (loadw arg1 arg1 symbol-value-slot other-pointer-lowtag
)
812 (inst li arg2
(fixnumize index
))
813 (inst addi arg3 sp n-foreign-linkage-area-bytes
)
814 ;; FIXME: This was (- (* RETURN-AREA-SIZE N-WORD-BYTES)), while
815 ;; RETURN-AREA-SIZE was (* N-RETURN-AREA-WORDS N-WORD-BYTES):
816 ;; I assume the intention was (- N-RETURN-AREA-BYTES), but who knows?
818 (inst addi arg4 sp
(- n-return-area-bytes
))
819 ;; FIXME! FIXME FIXME: What does this FIXME refer to?
820 ;; Save sp, setup the frame
822 (inst stw r0 sp
(* 2 n-word-bytes
)) ; FIXME: magic constant
823 (inst stwu sp sp
(- frame-size
))
825 (load-address-into r0
(foreign-symbol-address "funcall3"))
828 ;; We're back! Restore sp and lr, load the return value from just
829 ;; under sp, and return.
831 (inst lwz r0 sp
(* 2 n-word-bytes
))
834 ((sb!alien
::alien-single-float-type-p result-type
)
835 (let ((f1 (make-fpr 1)))
836 (inst lfs f1 sp
(- (* n-return-area-words n-word-bytes
)))))
837 ((sb!alien
::alien-double-float-type-p result-type
)
838 (let ((f1 (make-fpr 1)))
839 (inst lfd f1 sp
(- (* n-return-area-words n-word-bytes
)))))
840 ((sb!alien
::alien-void-type-p result-type
)
844 (loop with gprs
= (mapcar #'make-gpr
'(3 4))
845 repeat n-return-area-words
847 for offset from
(- (* n-return-area-words n-word-bytes
))
851 (bug "Out of return registers in alien-callback trampoline."))
852 (inst lwz gpr sp offset
))))
854 (finalize-segment segment
)
855 ;; Now that the segment is done, convert it to a static
856 ;; vector we can point foreign code to.
857 (let* ((buffer (sb!assem
::segment-buffer segment
))
858 (vector (make-static-vector (length buffer
)
859 :element-type
'(unsigned-byte 8)
860 :initial-contents buffer
))
861 (sap (vector-sap vector
)))
863 (extern-alien "ppc_flush_icache"