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-single-float-type-p type
)
273 (new-arg-types type
))
274 ((alien-double-float-type-p type
)
278 (incf stack
3) ; Doubles are aligned on
279 (incf stack
2))) ; the stack.
281 (new-arg-types type
))
287 (new-arg-types type
)))))
288 (cond ((and (alien-integer-type-p result-type
)
289 (> (sb!alien
::alien-integer-type-bits result-type
) 32))
290 (let ((new-result-type
291 (let ((sb!alien
::*values-type-okay
* t
))
293 (if (alien-integer-type-signed result-type
)
294 '(values (signed 32) (unsigned 32))
295 '(values (unsigned 32) (unsigned 32)))
296 (sb!kernel
:make-null-lexenv
)))))
297 `(lambda (function type
,@(lambda-vars))
298 (declare (ignore type
))
299 (multiple-value-bind (high low
)
300 (%alien-funcall function
301 ',(make-alien-fun-type
302 :arg-types
(new-arg-types)
303 :result-type new-result-type
)
305 (logior low
(ash high
32))))))
307 `(lambda (function type
,@(lambda-vars))
308 (declare (ignore type
))
309 (%alien-funcall function
310 ',(make-alien-fun-type
311 :arg-types
(new-arg-types)
312 :result-type result-type
)
314 (sb!c
::give-up-ir1-transform
))))
317 (deftransform %alien-funcall
((function type
&rest args
))
318 (aver (sb!c
::constant-lvar-p type
))
319 (let* ((type (sb!c
::lvar-value type
))
320 (arg-types (alien-fun-type-arg-types type
))
321 (result-type (alien-fun-type-result-type type
)))
322 (aver (= (length arg-types
) (length args
)))
323 ;; We need to do something special for 64-bit integer arguments
325 (if (or (some #'(lambda (type)
326 (and (alien-integer-type-p type
)
327 (> (sb!alien
::alien-integer-type-bits type
) 32)))
329 (and (alien-integer-type-p result-type
)
330 (> (sb!alien
::alien-integer-type-bits result-type
) 32)))
331 (collect ((new-args) (lambda-vars) (new-arg-types))
332 (dolist (type arg-types
)
333 (let ((arg (gensym)))
335 (cond ((and (alien-integer-type-p type
)
336 (> (sb!alien
::alien-integer-type-bits type
) 32))
337 ;; 64-bit long long types are stored in
338 ;; consecutive locations, most significant word
339 ;; first (big-endian).
340 (new-args `(ash ,arg -
32))
341 (new-args `(logand ,arg
#xffffffff
))
342 (if (alien-integer-type-signed type
)
343 (new-arg-types (parse-alien-type '(signed 32) (sb!kernel
:make-null-lexenv
)))
344 (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel
:make-null-lexenv
))))
345 (new-arg-types (parse-alien-type '(unsigned 32) (sb!kernel
:make-null-lexenv
))))
348 (new-arg-types type
)))))
349 (cond ((and (alien-integer-type-p result-type
)
350 (> (sb!alien
::alien-integer-type-bits result-type
) 32))
351 (let ((new-result-type
352 (let ((sb!alien
::*values-type-okay
* t
))
354 (if (alien-integer-type-signed result-type
)
355 '(values (signed 32) (unsigned 32))
356 '(values (unsigned 32) (unsigned 32)))
357 (sb!kernel
:make-null-lexenv
)))))
358 `(lambda (function type
,@(lambda-vars))
359 (declare (ignore type
))
360 (multiple-value-bind (high low
)
361 (%alien-funcall function
362 ',(make-alien-fun-type
363 :arg-types
(new-arg-types)
364 :result-type new-result-type
)
366 (logior low
(ash high
32))))))
368 `(lambda (function type
,@(lambda-vars))
369 (declare (ignore type
))
370 (%alien-funcall function
371 ',(make-alien-fun-type
372 :arg-types
(new-arg-types)
373 :result-type result-type
)
375 (sb!c
::give-up-ir1-transform
))))
377 (define-vop (foreign-symbol-sap)
378 (:translate foreign-symbol-sap
)
381 (:arg-types
(:constant simple-string
))
382 (:info foreign-symbol
)
383 (:results
(res :scs
(sap-reg)))
384 (:result-types system-area-pointer
)
386 (inst lr res
(make-fixup foreign-symbol
:foreign
))))
389 (define-vop (foreign-symbol-dataref-sap)
390 (:translate foreign-symbol-dataref-sap
)
393 (:arg-types
(:constant simple-string
))
394 (:info foreign-symbol
)
395 (:results
(res :scs
(sap-reg)))
396 (:result-types system-area-pointer
)
397 (:temporary
(:scs
(non-descriptor-reg)) addr
)
399 (inst lr addr
(make-fixup foreign-symbol
:foreign-dataref
))
402 (define-vop (call-out)
403 (:args
(function :scs
(sap-reg) :target cfunc
)
405 (:results
(results :more t
))
406 (:ignore args results
)
408 (:temporary
(:sc any-reg
:offset cfunc-offset
409 :from
(:argument
0) :to
(:result
0)) cfunc
)
410 (:temporary
(:sc control-stack
:offset nfp-save-offset
) nfp-save
)
411 (:temporary
(:scs
(non-descriptor-reg)) temp
)
414 (let ((cur-nfp (current-nfp-tn vop
)))
416 (store-stack-tn nfp-save cur-nfp
))
417 (inst lr temp
(make-fixup "call_into_c" :foreign
))
419 (move cfunc function
)
422 (load-stack-tn cur-nfp nfp-save
)))))
425 (define-vop (alloc-number-stack-space)
427 (:results
(result :scs
(sap-reg any-reg
)))
428 (:result-types system-area-pointer
)
429 (:temporary
(:scs
(unsigned-reg) :to
(:result
0)) temp
)
431 (unless (zerop amount
)
432 ;; FIXME: I don't understand why we seem to be adding
433 ;; NUMBER-STACK-DISPLACEMENT twice here. Weird. -- CSR,
435 (let ((delta (- (logandc2 (+ amount number-stack-displacement
436 +stack-alignment-bytes
+)
437 +stack-alignment-bytes
+))))
438 (cond ((>= delta
(ash -
1 16))
439 (inst stwu nsp-tn nsp-tn delta
))
442 (inst stwux nsp-tn nsp-tn temp
)))))
443 (unless (location= result nsp-tn
)
444 ;; They are only location= when the result tn was allocated by
445 ;; make-call-out-tns above, which takes the number-stack-displacement
446 ;; into account itself.
447 (inst addi result nsp-tn number-stack-displacement
))))
449 (define-vop (dealloc-number-stack-space)
453 (unless (zerop amount
)
454 (let ((delta (logandc2 (+ amount number-stack-displacement
455 +stack-alignment-bytes
+)
456 +stack-alignment-bytes
+)))
457 (cond ((< delta
(ash 1 16))
458 (inst addi nsp-tn nsp-tn delta
))
460 (inst lwz nsp-tn nsp-tn
0)))))))
464 (defun alien-callback-accessor-form (type sap offset
)
466 (sb!alien
::parse-alien-type type
(sb!kernel
:make-null-lexenv
))))
467 (cond ((sb!alien
::alien-integer-type-p parsed-type
)
468 ;; Unaligned access is slower, but possible, so this is nice and
469 ;; simple. Also, we're a big-endian machine, so we need to get
470 ;; byte offsets correct.
471 (let ((bits (sb!alien
::alien-type-bits parsed-type
)))
473 (cond ((< bits n-word-bits
)
475 (ceiling bits n-byte-bits
)))
477 `(deref (sap-alien (sap+ ,sap
478 ,(+ byte-offset offset
))
481 `(deref (sap-alien (sap+ ,sap
,offset
) (* ,type
)))))))
483 ;;; The "Mach-O Runtime Conventions" document for OS X almost
484 ;;; specifies the calling convention (it neglects to mention that
485 ;;; the linkage area is 24 bytes).
487 (defconstant n-foreign-linkage-area-bytes
24)
489 ;;; On linux only use 8 bytes for LR and Back chain. JRXR
492 (defconstant n-foreign-linkage-area-bytes
8)
494 ;;; Returns a vector in static space containing machine code for the
495 ;;; callback wrapper. Linux version. JRXR. 2006/11/13
497 (defun alien-callback-assembler-wrapper (index result-type argument-types
)
499 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'any-reg
) :offset n
))
501 (make-random-tn :kind
:normal
:sc
(sc-or-lose
504 (let* ((segment (make-segment)))
506 ;; Copy args from registers or stack to new position
513 (mapcar (lambda (type)
514 (ceiling (alien-type-bits type
)
517 ;; Return area allocation.
519 (ceiling (or (alien-type-bits result-type
) 0) n-word-bits
))
520 (n-return-area-bytes (* n-return-area-words
522 ;; FIXME: magic constant, and probably n-args-bytes
523 ;; JRXR: What's this for? Copied from Darwin.
524 (args-size (* 3 n-word-bytes
))
525 (frame-size (logandc2
529 SB
!VM
::NUMBER-STACK-DISPLACEMENT
530 +stack-alignment-bytes
+)
531 +stack-alignment-bytes
+))
532 (return-area-pos (- frame-size
533 SB
!VM
::NUMBER-STACK-DISPLACEMENT
535 (arg-store-pos (- return-area-pos
536 n-return-area-bytes
))
537 (stack-pointer (make-gpr 1))
540 (in-words-processed 0)
541 (out-words-processed 0)
542 (gprs (mapcar #'make-gpr
'(3 4 5 6 7 8 9 10)))
543 (fprs (mapcar #'make-fpr
544 '(1 2 3 4 5 6 7 8))) )
545 ;; Setup useful functions and then copy all args.
546 (flet ((load-address-into (reg addr
)
547 (let ((high (ldb (byte 16 16) addr
))
548 (low (ldb (byte 16 0) addr
)))
550 (inst ori reg reg low
)))
551 (save-arg (type words
)
552 (let ((integerp (not (alien-float-type-p type
)))
553 (in-offset (+ (* in-words-processed n-word-bytes
)
554 n-foreign-linkage-area-bytes
))
555 (out-offset (- (* out-words-processed n-word-bytes
)
559 ;; Only upto long longs are passed
562 ;; And needs space for whole arg,
563 ;; including alignment.
565 (rem (length gprs
) words
))
569 (rem (length gprs
) words
))
572 (let ((gpr (pop gprs
)))
573 (inst stw gpr stack-pointer
575 (incf out-words-processed
)
576 (incf out-offset n-word-bytes
)))
578 ;; First ensure alignment.
579 ;; FIXME! If passing structures
580 ;; becomes allowable, then this is
583 (rem in-words-processed
586 (incf in-words-processed
)
590 ;; Copy from memory to memory.
591 (inst lwz r0 stack-pointer
593 (inst stw r0 stack-pointer
595 (incf out-words-processed
)
596 (incf out-offset n-word-bytes
)
597 (incf in-words-processed
)
598 (incf in-offset n-word-bytes
)))))
599 ;; The handling of floats is a little ugly
600 ;; because we hard-code the number of words
601 ;; for single- and double-floats.
602 ((alien-single-float-type-p type
)
603 (let ((fpr (pop fprs
)))
605 (inst stfs fpr stack-pointer out-offset
)
607 ;; The ABI says that floats
608 ;; stored on the stack are
609 ;; promoted to doubles. gcc
610 ;; stores them as floats.
612 ;; => no alignment needed either.
614 stack-pointer in-offset
)
616 stack-pointer out-offset
)
617 (incf in-words-processed
))))
618 (incf out-words-processed
))
619 ((alien-double-float-type-p type
)
620 (let ((fpr (pop fprs
)))
622 (inst stfd fpr stack-pointer out-offset
)
625 (if (oddp in-words-processed
)
627 (incf in-words-processed
)
628 (incf in-offset n-word-bytes
)))
630 stack-pointer in-offset
)
632 stack-pointer out-offset
)
633 (incf in-words-processed
2))))
634 (incf out-words-processed
2))
636 (bug "Unknown alien floating point type: ~S" type
))))))
639 (mapcar (lambda (arg)
640 (ceiling (alien-type-bits arg
) n-word-bits
))
643 ;; Arranged the args, allocated the return area. Now
644 ;; actuall call funcall3: funcall3 (call-alien-function,
645 ;; index, args, return-area)
647 (destructuring-bind (arg1 arg2 arg3 arg4
)
648 (mapcar #'make-gpr
'(3 4 5 6))
649 (load-address-into arg1
(+ nil-value
(static-symbol-offset
650 'sb
!alien
::*enter-alien-callback
*)))
651 (loadw arg1 arg1 symbol-value-slot other-pointer-lowtag
)
652 (inst li arg2
(fixnumize index
))
653 (inst addi arg3 stack-pointer
(- arg-store-pos
))
654 (inst addi arg4 stack-pointer
(- return-area-pos
)))
656 ;; Setup everything. Now save sp, setup the frame.
658 (inst stw r0 stack-pointer
(* 2 n-word-bytes
)) ; FIXME: magic
659 ; constant, copied from Darwin.
660 (inst stwu stack-pointer stack-pointer
(- frame-size
))
662 ;; And make the call.
663 (load-address-into r0
(foreign-symbol-address "funcall3"))
667 ;; We're back! Restore sp and lr, load the
668 ;; return value from just under sp, and return.
669 (inst lwz stack-pointer stack-pointer
0)
670 (inst lwz r0 stack-pointer
(* 2 n-word-bytes
))
673 ((sb!alien
::alien-single-float-type-p result-type
)
674 (let ((f1 (make-fpr 1)))
675 (inst lfs f1 stack-pointer
(- return-area-pos
))))
676 ((sb!alien
::alien-double-float-type-p result-type
)
677 (let ((f1 (make-fpr 1)))
678 (inst lfd f1 stack-pointer
(- return-area-pos
))))
679 ((sb!alien
::alien-void-type-p result-type
)
683 (loop with gprs
= (mapcar #'make-gpr
'(3 4))
684 repeat n-return-area-words
686 for offset from
(- return-area-pos
)
690 (bug "Out of return registers in alien-callback trampoline."))
691 (inst lwz gpr stack-pointer offset
))))
693 (finalize-segment segment
)
695 ;; Now that the segment is done, convert it to a static
696 ;; vector we can point foreign code to.
697 (let* ((buffer (sb!assem
::segment-buffer segment
))
698 (vector (make-static-vector (length buffer
)
699 :element-type
'(unsigned-byte 8)
700 :initial-contents buffer
))
701 (sap (sb!sys
:vector-sap vector
)))
702 (sb!alien
:alien-funcall
703 (sb!alien
:extern-alien
"ppc_flush_icache"
710 ;;; Returns a vector in static space containing machine code for the
713 (defun alien-callback-assembler-wrapper (index result-type argument-types
)
715 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'any-reg
) :offset n
))
717 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'double-reg
) :offset n
)))
718 (let* ((segment (make-segment)))
720 ;; To save our arguments, we follow the algorithm sketched in the
721 ;; "PowerPC Calling Conventions" section of that document.
723 ;; CLH: There are a couple problems here. First, we bail if
724 ;; we run out of registers. AIUI, we can just ignore the extra
725 ;; args here and we will be ok...
726 (let ((words-processed 0)
727 (gprs (mapcar #'make-gpr
'(3 4 5 6 7 8 9 10)))
728 (fprs (mapcar #'make-fpr
'(1 2 3 4 5 6 7 8 9 10 11 12 13)))
729 (stack-pointer (make-gpr 1)))
730 (labels ((save-arg (type words
)
731 (let ((integerp (not (alien-float-type-p type
)))
732 (offset (+ (* words-processed n-word-bytes
)
733 n-foreign-linkage-area-bytes
)))
736 (let ((gpr (pop gprs
)))
738 (inst stw gpr stack-pointer offset
))
739 (incf words-processed
)
740 (incf offset n-word-bytes
))))
741 ;; The handling of floats is a little ugly
742 ;; because we hard-code the number of words
743 ;; for single- and double-floats.
744 ((alien-single-float-type-p type
)
746 (let ((fpr (pop fprs
)))
748 (inst stfs fpr stack-pointer offset
)))
749 (incf words-processed
))
750 ((alien-double-float-type-p type
)
751 (setf gprs
(cddr gprs
))
752 (let ((fpr (pop fprs
)))
754 (inst stfd fpr stack-pointer offset
)))
755 (incf words-processed
2))
757 (bug "Unknown alien floating point type: ~S" type
))))))
760 (mapcar (lambda (arg)
761 (ceiling (alien-type-bits arg
) n-word-bits
))
763 ;; Set aside room for the return area just below sp, then
764 ;; actually call funcall3: funcall3 (call-alien-function,
765 ;; index, args, return-area)
767 ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to be
768 ;; because they're word-aligned. Kinda gross, but hey ...
769 (let* ((n-return-area-words
770 (ceiling (or (alien-type-bits result-type
) 0) n-word-bits
))
771 (n-return-area-bytes (* n-return-area-words n-word-bytes
))
772 ;; FIXME: magic constant, and probably n-args-bytes
773 (args-size (* 3 n-word-bytes
))
774 ;; FIXME: n-frame-bytes?
775 (frame-size (logandc2 (+ n-foreign-linkage-area-bytes
778 +stack-alignment-bytes
+)
779 +stack-alignment-bytes
+)))
780 (destructuring-bind (sp r0 arg1 arg2 arg3 arg4
)
781 (mapcar #'make-gpr
'(1 0 3 4 5 6))
782 ;; FIXME: This is essentially the same code as LR in
783 ;; insts.lisp, but attempting to use (INST LR ...) instead
784 ;; of this function results in callbacks not working. Why?
786 (flet ((load-address-into (reg addr
)
787 (let ((high (ldb (byte 16 16) addr
))
788 (low (ldb (byte 16 0) addr
)))
790 (inst ori reg reg low
))))
793 ;; CLH 2006/02/10 -Following JES' logic in
794 ;; x86-64/c-call.lisp, we need to access
795 ;; ENTER-ALIEN-CALLBACK through the symbol-value slot
796 ;; of SB-ALIEN::*ENTER-ALIEN-CALLBACK* to ensure that
797 ;; it works if GC moves ENTER-ALIEN-CALLBACK.
800 ;; (load-address-into arg1 (get-lisp-obj-address #'enter-alien-callback))
803 ;; (load-symbol arg1 'sb!alien::*enter-alien-callback*)
805 ;; whoops: can't use load-symbol here as null-tn might
806 ;; not be loaded with the proper value as we are
807 ;; coming in from C code. Use nil-value constant
808 ;; instead, following the logic in x86-64/c-call.lisp.
809 (load-address-into arg1
(+ nil-value
(static-symbol-offset
810 'sb
!alien
::*enter-alien-callback
*)))
811 (loadw arg1 arg1 symbol-value-slot other-pointer-lowtag
)
813 (inst li arg2
(fixnumize index
))
814 (inst addi arg3 sp n-foreign-linkage-area-bytes
)
815 ;; FIXME: This was (- (* RETURN-AREA-SIZE N-WORD-BYTES)), while
816 ;; RETURN-AREA-SIZE was (* N-RETURN-AREA-WORDS N-WORD-BYTES):
817 ;; I assume the intention was (- N-RETURN-AREA-BYTES), but who knows?
819 (inst addi arg4 sp
(- n-return-area-bytes
))
820 ;; FIXME! FIXME FIXME: What does this FIXME refer to?
821 ;; Save sp, setup the frame
823 (inst stw r0 sp
(* 2 n-word-bytes
)) ; FIXME: magic constant
824 (inst stwu sp sp
(- frame-size
))
826 (load-address-into r0
(foreign-symbol-address "funcall3"))
829 ;; We're back! Restore sp and lr, load the return value from just
830 ;; under sp, and return.
832 (inst lwz r0 sp
(* 2 n-word-bytes
))
835 ((sb!alien
::alien-single-float-type-p result-type
)
836 (let ((f1 (make-fpr 1)))
837 (inst lfs f1 sp
(- (* n-return-area-words n-word-bytes
)))))
838 ((sb!alien
::alien-double-float-type-p result-type
)
839 (let ((f1 (make-fpr 1)))
840 (inst lfd f1 sp
(- (* n-return-area-words n-word-bytes
)))))
841 ((sb!alien
::alien-void-type-p result-type
)
845 (loop with gprs
= (mapcar #'make-gpr
'(3 4))
846 repeat n-return-area-words
848 for offset from
(- (* n-return-area-words n-word-bytes
))
852 (bug "Out of return registers in alien-callback trampoline."))
853 (inst lwz gpr sp offset
))))
855 (finalize-segment segment
)
856 ;; Now that the segment is done, convert it to a static
857 ;; vector we can point foreign code to.
858 (let* ((buffer (sb!assem
::segment-buffer segment
))
859 (vector (make-static-vector (length buffer
)
860 :element-type
'(unsigned-byte 8)
861 :initial-contents buffer
))
862 (sap (sb!sys
:vector-sap vector
)))
863 (sb!alien
:alien-funcall
864 (sb!alien
:extern-alien
"ppc_flush_icache"