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.
29 ;; SVR4 [a]abi wants two words on stack (callee saved lr,
31 #!-darwin
(stack-frame-size 2)
32 ;; PowerOpen ABI wants 8 words on the stack corresponding to GPR3-10
33 ;; in addition to the 6 words of link area (see number-stack-displacement)
34 #!+darwin
(stack-frame-size (+ 8 6)))
36 (defun int-arg (state prim-type reg-sc stack-sc
)
37 (let ((reg-args (arg-state-gpr-args state
)))
39 (setf (arg-state-gpr-args state
) (1+ reg-args
))
40 (make-wired-tn* prim-type reg-sc
(+ reg-args nl0-offset
)))
42 (let ((frame-size (arg-state-stack-frame-size state
)))
43 (setf (arg-state-stack-frame-size state
) (1+ frame-size
))
44 (make-wired-tn* prim-type stack-sc frame-size
))))))
46 (define-alien-type-method (integer :arg-tn
) (type state
)
47 (if (alien-integer-type-signed type
)
48 (int-arg state
'signed-byte-32 signed-reg-sc-number signed-stack-sc-number
)
49 (int-arg state
'unsigned-byte-32 unsigned-reg-sc-number unsigned-stack-sc-number
)))
51 (define-alien-type-method (system-area-pointer :arg-tn
) (type state
)
52 (declare (ignore type
))
53 (int-arg state
'system-area-pointer sap-reg-sc-number sap-stack-sc-number
))
55 ;;; The Linux/PPC 32bit ABI says:
57 ;;; If a single-float arg has to go on the stack, it's promoted to
62 ;;; Excess floats stored on the stack are stored as floats.
66 (define-alien-type-method (single-float :arg-tn
) (type state
)
67 (declare (ignore type
))
68 (let* ((fprs (arg-state-fpr-args state
)))
70 (incf (arg-state-fpr-args state
))
71 ;; Assign outgoing FPRs starting at FP1
72 (make-wired-tn* 'single-float single-reg-sc-number
(1+ fprs
)))
74 (let* ((stack-offset (arg-state-stack-frame-size state
)))
75 (setf (arg-state-stack-frame-size state
) (+ stack-offset
1))
76 (make-wired-tn* 'single-float single-stack-sc-number stack-offset
))))))
78 ;;; If a single-float arg has to go on the stack, it's promoted to
79 ;;; double. That way, C programs can get subtle rounding errors when
80 ;;; unrelated arguments are introduced.
82 (define-alien-type-method (single-float :arg-tn
) (type state
)
83 (declare (ignore type
))
84 (let* ((fprs (arg-state-fpr-args state
))
85 (gprs (arg-state-gpr-args state
)))
86 (cond ((< gprs
8) ; and by implication also (< fprs 13)
87 (incf (arg-state-fpr-args state
))
88 ;; Assign outgoing FPRs starting at FP1
89 (list (make-wired-tn* 'single-float single-reg-sc-number
(1+ fprs
))
90 (int-arg state
'signed-byte-32 signed-reg-sc-number signed-stack-sc-number
)))
92 ;; See comments below for double-float.
93 (incf (arg-state-fpr-args state
))
94 (incf (arg-state-stack-frame-size state
))
95 (make-wired-tn* 'single-float single-reg-sc-number
(1+ fprs
)))
98 (let ((stack-offset (arg-state-stack-frame-size state
)))
99 (incf (arg-state-stack-frame-size state
))
100 (make-wired-tn* 'single-float single-stack-sc-number stack-offset
))))))
103 (define-alien-type-method (double-float :arg-tn
) (type state
)
104 (declare (ignore type
))
105 (let* ((fprs (arg-state-fpr-args state
)))
107 (incf (arg-state-fpr-args state
))
108 ;; Assign outgoing FPRs starting at FP1
109 (make-wired-tn* 'double-float double-reg-sc-number
(1+ fprs
)))
111 (let* ((stack-offset (arg-state-stack-frame-size state
)))
112 (if (oddp stack-offset
)
114 (setf (arg-state-stack-frame-size state
) (+ stack-offset
2))
115 (make-wired-tn* 'double-float double-stack-sc-number stack-offset
))))))
118 (define-alien-type-method (double-float :arg-tn
) (type state
)
119 (declare (ignore type
))
120 (let ((fprs (arg-state-fpr-args state
))
121 (gprs (arg-state-gpr-args state
)))
122 (cond ((< gprs
8) ; and by implication also (< fprs 13)
123 (incf (arg-state-fpr-args state
))
124 ;; Assign outgoing FPRs starting at FP1
126 ;; The PowerOpen ABI says float values are stored in float
127 ;; regs. But if we're calling a varargs function, we also
128 ;; need to put the float into some gprs. We indicate this
129 ;; to %alien-funcall ir2-convert by making a list of the
130 ;; TNs for the float reg and for the int regs.
132 (list (make-wired-tn* 'double-float double-reg-sc-number
(1+ fprs
))
133 (int-arg state
'signed-byte-32 signed-reg-sc-number signed-stack-sc-number
)
134 (int-arg state
'unsigned-byte-32 unsigned-reg-sc-number unsigned-stack-sc-number
)))
136 (incf (arg-state-fpr-args state
))
137 (list (make-wired-tn* 'double-float double-reg-sc-number
(1+ fprs
))
138 (int-arg state
'signed-byte-32 signed-reg-sc-number signed-stack-sc-number
)
139 (int-arg state
'unsigned-byte-32 unsigned-reg-sc-number unsigned-stack-sc-number
)))
141 ;; Pass on stack only
142 (let ((stack-offset (arg-state-stack-frame-size state
)))
143 (incf (arg-state-stack-frame-size state
) 2)
144 (make-wired-tn* 'double-float double-stack-sc-number stack-offset
))))))
146 ;;; Result state handling
148 (defstruct result-state
151 (defun result-reg-offset (slot)
156 ;;; FIXME: These #!-DARWIN methods should be adjusted to take a state
157 ;;; argument, firstly because that's our "official" API (see
158 ;;; src/code/host-alieneval) and secondly because that way we can
159 ;;; probably have less duplication of code. -- CSR, 2003-07-29
161 (define-alien-type-method (system-area-pointer :result-tn
) (type state
)
162 (declare (ignore type
))
163 (let ((num-results (result-state-num-results state
)))
164 (setf (result-state-num-results state
) (1+ num-results
))
165 (make-wired-tn* 'system-area-pointer sap-reg-sc-number
166 (result-reg-offset num-results
))))
168 (define-alien-type-method (single-float :result-tn
) (type state
)
169 (declare (ignore type state
))
170 (make-wired-tn* 'single-float single-reg-sc-number
1))
172 (define-alien-type-method (double-float :result-tn
) (type state
)
173 (declare (ignore type state
))
174 (make-wired-tn* 'double-float double-reg-sc-number
1))
176 (define-alien-type-method (values :result-tn
) (type state
)
177 (let ((values (alien-values-type-values type
)))
178 (when (> (length values
) 2)
179 (error "Too many result values from c-call."))
180 (mapcar #'(lambda (type)
181 (invoke-alien-type-method :result-tn type state
))
184 (define-alien-type-method (integer :result-tn
) (type state
)
185 (let ((num-results (result-state-num-results state
)))
186 (setf (result-state-num-results state
) (1+ num-results
))
187 (multiple-value-bind (ptype reg-sc
)
188 (if (alien-integer-type-signed type
)
189 (values 'signed-byte-32 signed-reg-sc-number
)
190 (values 'unsigned-byte-32 unsigned-reg-sc-number
))
191 (make-wired-tn* ptype reg-sc
(result-reg-offset num-results
)))))
193 (defun make-call-out-tns (type)
194 (declare (type alien-fun-type type
))
195 (let ((arg-state (make-arg-state)))
197 (dolist (arg-type (alien-fun-type-arg-types type
))
198 (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state
)))
199 (values (make-wired-tn* 'positive-fixnum any-reg-sc-number nsp-offset
)
200 (* (arg-state-stack-frame-size arg-state
) n-word-bytes
)
202 (invoke-alien-type-method
204 (alien-fun-type-result-type type
)
205 (make-result-state))))))
208 ;;; Sort out long longs, by splitting them up. However, need to take
209 ;;; care about register/stack alignment and whether they will fully
210 ;;; fit into registers or must go on the stack.
212 (deftransform %alien-funcall
((function type
&rest args
))
213 (aver (sb!c
::constant-lvar-p type
))
214 (let* ((type (sb!c
::lvar-value type
))
215 (arg-types (alien-fun-type-arg-types type
))
216 (result-type (alien-fun-type-result-type type
))
220 (aver (= (length arg-types
) (length args
)))
221 ;; We need to do something special for 64-bit integer arguments
223 (if (or (some #'(lambda (type)
224 (and (alien-integer-type-p type
)
225 (> (sb!alien
::alien-integer-type-bits type
) 32)))
227 (and (alien-integer-type-p result-type
)
228 (> (sb!alien
::alien-integer-type-bits result-type
) 32)))
229 (collect ((new-args) (lambda-vars) (new-arg-types))
230 (dolist (type arg-types
)
231 (let ((arg (gensym)))
233 (cond ((and (alien-integer-type-p type
)
234 (> (sb!alien
::alien-integer-type-bits type
) 32))
240 ;; Need to pad for alignment.
245 (new-arg-types (parse-alien-type
246 '(unsigned 32) nil
)))
250 (new-args `(ash ,arg -
32))
251 (new-args `(logand ,arg
#xffffffff
))
252 (if (alien-integer-type-signed type
)
253 (new-arg-types (parse-alien-type
255 (new-arg-types (parse-alien-type
256 '(unsigned 32) nil
)))
257 (new-arg-types (parse-alien-type
258 '(unsigned 32) nil
)))
259 ((alien-single-float-type-p type
)
264 (new-arg-types type
))
265 ((alien-double-float-type-p type
)
269 (incf stack
3) ; Doubles are aligned on
270 (incf stack
2))) ; the stack.
272 (new-arg-types type
))
278 (new-arg-types type
)))))
279 (cond ((and (alien-integer-type-p result-type
)
280 (> (sb!alien
::alien-integer-type-bits result-type
) 32))
281 (let ((new-result-type
282 (let ((sb!alien
::*values-type-okay
* t
))
284 (if (alien-integer-type-signed result-type
)
285 '(values (signed 32) (unsigned 32))
286 '(values (unsigned 32) (unsigned 32)))
288 `(lambda (function type
,@(lambda-vars))
289 (declare (ignore type
))
290 (multiple-value-bind (high low
)
291 (%alien-funcall function
292 ',(make-alien-fun-type
293 :arg-types
(new-arg-types)
294 :result-type new-result-type
)
296 (logior low
(ash high
32))))))
298 `(lambda (function type
,@(lambda-vars))
299 (declare (ignore type
))
300 (%alien-funcall function
301 ',(make-alien-fun-type
302 :arg-types
(new-arg-types)
303 :result-type result-type
)
305 (sb!c
::give-up-ir1-transform
))))
308 (deftransform %alien-funcall
((function type
&rest args
))
309 (aver (sb!c
::constant-lvar-p type
))
310 (let* ((type (sb!c
::lvar-value type
))
311 (arg-types (alien-fun-type-arg-types type
))
312 (result-type (alien-fun-type-result-type type
)))
313 (aver (= (length arg-types
) (length args
)))
314 ;; We need to do something special for 64-bit integer arguments
316 (if (or (some #'(lambda (type)
317 (and (alien-integer-type-p type
)
318 (> (sb!alien
::alien-integer-type-bits type
) 32)))
320 (and (alien-integer-type-p result-type
)
321 (> (sb!alien
::alien-integer-type-bits result-type
) 32)))
322 (collect ((new-args) (lambda-vars) (new-arg-types))
323 (dolist (type arg-types
)
324 (let ((arg (gensym)))
326 (cond ((and (alien-integer-type-p type
)
327 (> (sb!alien
::alien-integer-type-bits type
) 32))
328 ;; 64-bit long long types are stored in
329 ;; consecutive locations, most significant word
330 ;; first (big-endian).
331 (new-args `(ash ,arg -
32))
332 (new-args `(logand ,arg
#xffffffff
))
333 (if (alien-integer-type-signed type
)
334 (new-arg-types (parse-alien-type '(signed 32) nil
))
335 (new-arg-types (parse-alien-type '(unsigned 32) nil
)))
336 (new-arg-types (parse-alien-type '(unsigned 32) nil
)))
339 (new-arg-types type
)))))
340 (cond ((and (alien-integer-type-p result-type
)
341 (> (sb!alien
::alien-integer-type-bits result-type
) 32))
342 (let ((new-result-type
343 (let ((sb!alien
::*values-type-okay
* t
))
345 (if (alien-integer-type-signed result-type
)
346 '(values (signed 32) (unsigned 32))
347 '(values (unsigned 32) (unsigned 32)))
349 `(lambda (function type
,@(lambda-vars))
350 (declare (ignore type
))
351 (multiple-value-bind (high low
)
352 (%alien-funcall function
353 ',(make-alien-fun-type
354 :arg-types
(new-arg-types)
355 :result-type new-result-type
)
357 (logior low
(ash high
32))))))
359 `(lambda (function type
,@(lambda-vars))
360 (declare (ignore type
))
361 (%alien-funcall function
362 ',(make-alien-fun-type
363 :arg-types
(new-arg-types)
364 :result-type result-type
)
366 (sb!c
::give-up-ir1-transform
))))
368 (define-vop (foreign-symbol-sap)
369 (:translate foreign-symbol-sap
)
372 (:arg-types
(:constant simple-string
))
373 (:info foreign-symbol
)
374 (:results
(res :scs
(sap-reg)))
375 (:result-types system-area-pointer
)
377 (inst lr res
(make-fixup foreign-symbol
:foreign
))))
380 (define-vop (foreign-symbol-dataref-sap)
381 (:translate foreign-symbol-dataref-sap
)
384 (:arg-types
(:constant simple-string
))
385 (:info foreign-symbol
)
386 (:results
(res :scs
(sap-reg)))
387 (:result-types system-area-pointer
)
388 (:temporary
(:scs
(non-descriptor-reg)) addr
)
390 (inst lr addr
(make-fixup foreign-symbol
:foreign-dataref
))
393 (define-vop (call-out)
394 (:args
(function :scs
(sap-reg) :target cfunc
)
396 (:results
(results :more t
))
397 (:ignore args results
)
399 (:temporary
(:sc any-reg
:offset cfunc-offset
400 :from
(:argument
0) :to
(:result
0)) cfunc
)
401 (:temporary
(:sc control-stack
:offset nfp-save-offset
) nfp-save
)
402 (:temporary
(:scs
(non-descriptor-reg)) temp
)
405 (let ((cur-nfp (current-nfp-tn vop
)))
407 (store-stack-tn nfp-save cur-nfp
))
408 (inst lr temp
(make-fixup "call_into_c" :foreign
))
410 (move cfunc function
)
413 (load-stack-tn cur-nfp nfp-save
)))))
416 (define-vop (alloc-number-stack-space)
418 (:results
(result :scs
(sap-reg any-reg
)))
419 (:result-types system-area-pointer
)
420 (:temporary
(:scs
(unsigned-reg) :to
(:result
0)) temp
)
422 (unless (zerop amount
)
423 ;; FIXME: I don't understand why we seem to be adding
424 ;; NUMBER-STACK-DISPLACEMENT twice here. Weird. -- CSR,
426 (let ((delta (- (logandc2 (+ amount number-stack-displacement
427 +stack-alignment-bytes
+)
428 +stack-alignment-bytes
+))))
429 (cond ((>= delta
(ash -
1 16))
430 (inst stwu nsp-tn nsp-tn delta
))
433 (inst stwux nsp-tn nsp-tn temp
)))))
434 (unless (location= result nsp-tn
)
435 ;; They are only location= when the result tn was allocated by
436 ;; make-call-out-tns above, which takes the number-stack-displacement
437 ;; into account itself.
438 (inst addi result nsp-tn number-stack-displacement
))))
440 (define-vop (dealloc-number-stack-space)
444 (unless (zerop amount
)
445 (let ((delta (logandc2 (+ amount number-stack-displacement
446 +stack-alignment-bytes
+)
447 +stack-alignment-bytes
+)))
448 (cond ((< delta
(ash 1 16))
449 (inst addi nsp-tn nsp-tn delta
))
451 (inst lwz nsp-tn nsp-tn
0)))))))
455 (defun alien-callback-accessor-form (type sap offset
)
456 (let ((parsed-type (parse-alien-type type nil
)))
457 (cond ((sb!alien
::alien-integer-type-p parsed-type
)
458 ;; Unaligned access is slower, but possible, so this is nice and
459 ;; simple. Also, we're a big-endian machine, so we need to get
460 ;; byte offsets correct.
461 (let ((bits (sb!alien
::alien-type-bits parsed-type
)))
463 (cond ((< bits n-word-bits
)
465 (ceiling bits n-byte-bits
)))
467 `(deref (sap-alien (sap+ ,sap
468 ,(+ byte-offset offset
))
471 `(deref (sap-alien (sap+ ,sap
,offset
) (* ,type
)))))))
473 ;;; The "Mach-O Runtime Conventions" document for OS X almost
474 ;;; specifies the calling convention (it neglects to mention that
475 ;;; the linkage area is 24 bytes).
477 (defconstant n-foreign-linkage-area-bytes
24)
479 ;;; On linux only use 8 bytes for LR and Back chain. JRXR
482 (defconstant n-foreign-linkage-area-bytes
8)
484 ;;; Returns a vector in static space containing machine code for the
485 ;;; callback wrapper. Linux version. JRXR. 2006/11/13
487 (defun alien-callback-assembler-wrapper (index result-type argument-types
)
489 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'any-reg
) :offset n
))
491 (make-random-tn :kind
:normal
:sc
(sc-or-lose
494 (let* ((segment (make-segment)))
496 ;; Copy args from registers or stack to new position
503 (mapcar (lambda (type)
504 (ceiling (alien-type-bits type
)
507 ;; Return area allocation.
509 (ceiling (or (alien-type-bits result-type
) 0) n-word-bits
))
510 (n-return-area-bytes (* n-return-area-words
512 ;; FIXME: magic constant, and probably n-args-bytes
513 ;; JRXR: What's this for? Copied from Darwin.
514 (args-size (* 3 n-word-bytes
))
515 (frame-size (logandc2
519 number-stack-displacement
520 +stack-alignment-bytes
+)
521 +stack-alignment-bytes
+))
522 (return-area-pos (- frame-size
523 number-stack-displacement
525 (arg-store-pos (- return-area-pos
526 n-return-area-bytes
))
527 (stack-pointer (make-gpr 1))
530 (in-words-processed 0)
531 (out-words-processed 0)
532 (gprs (mapcar #'make-gpr
'(3 4 5 6 7 8 9 10)))
533 (fprs (mapcar #'make-fpr
534 '(1 2 3 4 5 6 7 8))) )
535 ;; Setup useful functions and then copy all args.
536 (flet ((load-address-into (reg addr
)
537 (let ((high (ldb (byte 16 16) addr
))
538 (low (ldb (byte 16 0) addr
)))
540 (inst ori reg reg low
)))
541 (save-arg (type words
)
542 (let ((integerp (not (alien-float-type-p type
)))
543 (in-offset (+ (* in-words-processed n-word-bytes
)
544 n-foreign-linkage-area-bytes
))
545 (out-offset (- (* out-words-processed n-word-bytes
)
549 ;; Only upto long longs are passed
552 ;; And needs space for whole arg,
553 ;; including alignment.
555 (rem (length gprs
) words
))
559 (rem (length gprs
) words
))
562 (let ((gpr (pop gprs
)))
563 (inst stw gpr stack-pointer
565 (incf out-words-processed
)
566 (incf out-offset n-word-bytes
)))
568 ;; First ensure alignment.
569 ;; FIXME! If passing structures
570 ;; becomes allowable, then this is
573 (rem in-words-processed
576 (incf in-words-processed
)
580 ;; Copy from memory to memory.
581 (inst lwz r0 stack-pointer
583 (inst stw r0 stack-pointer
585 (incf out-words-processed
)
586 (incf out-offset n-word-bytes
)
587 (incf in-words-processed
)
588 (incf in-offset n-word-bytes
)))))
589 ;; The handling of floats is a little ugly
590 ;; because we hard-code the number of words
591 ;; for single- and double-floats.
592 ((alien-single-float-type-p type
)
593 (let ((fpr (pop fprs
)))
595 (inst stfs fpr stack-pointer out-offset
)
597 ;; The ABI says that floats
598 ;; stored on the stack are
599 ;; promoted to doubles. gcc
600 ;; stores them as floats.
602 ;; => no alignment needed either.
604 stack-pointer in-offset
)
606 stack-pointer out-offset
)
607 (incf in-words-processed
))))
608 (incf out-words-processed
))
609 ((alien-double-float-type-p type
)
610 (let ((fpr (pop fprs
)))
612 (inst stfd fpr stack-pointer out-offset
)
615 (if (oddp in-words-processed
)
617 (incf in-words-processed
)
618 (incf in-offset n-word-bytes
)))
620 stack-pointer in-offset
)
622 stack-pointer out-offset
)
623 (incf in-words-processed
2))))
624 (incf out-words-processed
2))
626 (bug "Unknown alien floating point type: ~S" type
))))))
629 (mapcar (lambda (arg)
630 (ceiling (alien-type-bits arg
) n-word-bits
))
633 ;; Arranged the args, allocated the return area. Now
634 ;; actuall call funcall3: funcall3 (call-alien-function,
635 ;; index, args, return-area)
637 (destructuring-bind (arg1 arg2 arg3 arg4
)
638 (mapcar #'make-gpr
'(3 4 5 6))
639 (load-address-into arg1
(static-fdefn-fun-addr 'enter-alien-callback
))
641 (inst li arg2
(fixnumize index
))
642 (inst addi arg3 stack-pointer
(- arg-store-pos
))
643 (inst addi arg4 stack-pointer
(- return-area-pos
)))
645 ;; Setup everything. Now save sp, setup the frame.
647 (inst stw r0 stack-pointer
(* 2 n-word-bytes
)) ; FIXME: magic
648 ; constant, copied from Darwin.
649 (inst stwu stack-pointer stack-pointer
(- frame-size
))
651 ;; And make the call.
654 (foreign-symbol-address
655 #!-sb-thread
"funcall3"
656 #!+sb-thread
"callback_wrapper_trampoline"))
660 ;; We're back! Restore sp and lr, load the
661 ;; return value from just under sp, and return.
662 (inst lwz stack-pointer stack-pointer
0)
663 (inst lwz r0 stack-pointer
(* 2 n-word-bytes
))
666 ((sb!alien
::alien-single-float-type-p result-type
)
667 (let ((f1 (make-fpr 1)))
668 (inst lfs f1 stack-pointer
(- return-area-pos
))))
669 ((sb!alien
::alien-double-float-type-p result-type
)
670 (let ((f1 (make-fpr 1)))
671 (inst lfd f1 stack-pointer
(- return-area-pos
))))
672 ((sb!alien
::alien-void-type-p result-type
)
676 (loop with gprs
= (mapcar #'make-gpr
'(3 4))
677 repeat n-return-area-words
679 for offset from
(- return-area-pos
)
683 (bug "Out of return registers in alien-callback trampoline."))
684 (inst lwz gpr stack-pointer offset
))))
686 (finalize-segment segment
)
688 ;; Now that the segment is done, convert it to a static
689 ;; vector we can point foreign code to.
690 (let* ((buffer (sb!assem
::segment-buffer segment
))
691 (vector (make-static-vector (length buffer
)
692 :element-type
'(unsigned-byte 8)
693 :initial-contents buffer
))
694 (sap (vector-sap vector
)))
696 (extern-alien "ppc_flush_icache"
703 ;;; Returns a vector in static space containing machine code for the
706 (defun alien-callback-assembler-wrapper (index result-type argument-types
)
708 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'any-reg
) :offset n
))
710 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'double-reg
) :offset n
)))
711 (let* ((segment (make-segment)))
713 ;; To save our arguments, we follow the algorithm sketched in the
714 ;; "PowerPC Calling Conventions" section of that document.
716 ;; CLH: There are a couple problems here. First, we bail if
717 ;; we run out of registers. AIUI, we can just ignore the extra
718 ;; args here and we will be ok...
719 (let ((words-processed 0)
720 (gprs (mapcar #'make-gpr
'(3 4 5 6 7 8 9 10)))
721 (fprs (mapcar #'make-fpr
'(1 2 3 4 5 6 7 8 9 10 11 12 13)))
722 (stack-pointer (make-gpr 1)))
723 (labels ((save-arg (type words
)
724 (let ((integerp (not (alien-float-type-p type
)))
725 (offset (+ (* words-processed n-word-bytes
)
726 n-foreign-linkage-area-bytes
)))
729 (let ((gpr (pop gprs
)))
731 (inst stw gpr stack-pointer offset
))
732 (incf words-processed
)
733 (incf offset n-word-bytes
))))
734 ;; The handling of floats is a little ugly
735 ;; because we hard-code the number of words
736 ;; for single- and double-floats.
737 ((alien-single-float-type-p type
)
739 (let ((fpr (pop fprs
)))
741 (inst stfs fpr stack-pointer offset
)))
742 (incf words-processed
))
743 ((alien-double-float-type-p type
)
744 (setf gprs
(cddr gprs
))
745 (let ((fpr (pop fprs
)))
747 (inst stfd fpr stack-pointer offset
)))
748 (incf words-processed
2))
750 (bug "Unknown alien floating point type: ~S" type
))))))
753 (mapcar (lambda (arg)
754 (ceiling (alien-type-bits arg
) n-word-bits
))
756 ;; Set aside room for the return area just below sp, then
757 ;; actually call funcall3: funcall3 (call-alien-function,
758 ;; index, args, return-area)
760 ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to be
761 ;; because they're word-aligned. Kinda gross, but hey ...
762 (let* ((n-return-area-words
763 (ceiling (or (alien-type-bits result-type
) 0) n-word-bits
))
764 (n-return-area-bytes (* n-return-area-words n-word-bytes
))
765 ;; FIXME: magic constant, and probably n-args-bytes
766 (args-size (* 3 n-word-bytes
))
767 ;; FIXME: n-frame-bytes?
768 (frame-size (logandc2 (+ n-foreign-linkage-area-bytes
771 +stack-alignment-bytes
+)
772 +stack-alignment-bytes
+)))
773 (destructuring-bind (sp r0 arg1 arg2 arg3 arg4
)
774 (mapcar #'make-gpr
'(1 0 3 4 5 6))
775 ;; FIXME: This is essentially the same code as LR in
776 ;; insts.lisp, but attempting to use (INST LR ...) instead
777 ;; of this function results in callbacks not working. Why?
779 (flet ((load-address-into (reg addr
)
780 (let ((high (ldb (byte 16 16) addr
))
781 (low (ldb (byte 16 0) addr
)))
783 (inst ori reg reg low
))))
785 (load-address-into arg1
(static-fdefn-fun-addr 'enter-alien-callback
))
787 (inst li arg2
(fixnumize index
))
788 (inst addi arg3 sp n-foreign-linkage-area-bytes
)
789 ;; FIXME: This was (- (* RETURN-AREA-SIZE N-WORD-BYTES)), while
790 ;; RETURN-AREA-SIZE was (* N-RETURN-AREA-WORDS N-WORD-BYTES):
791 ;; I assume the intention was (- N-RETURN-AREA-BYTES), but who knows?
793 (inst addi arg4 sp
(- n-return-area-bytes
))
794 ;; FIXME! FIXME FIXME: What does this FIXME refer to?
795 ;; Save sp, setup the frame
797 (inst stw r0 sp
(* 2 n-word-bytes
)) ; FIXME: magic constant
798 (inst stwu sp sp
(- frame-size
))
800 (load-address-into r0
(foreign-symbol-address "funcall3"))
803 ;; We're back! Restore sp and lr, load the return value from just
804 ;; under sp, and return.
806 (inst lwz r0 sp
(* 2 n-word-bytes
))
809 ((sb!alien
::alien-single-float-type-p result-type
)
810 (let ((f1 (make-fpr 1)))
811 (inst lfs f1 sp
(- (* n-return-area-words n-word-bytes
)))))
812 ((sb!alien
::alien-double-float-type-p result-type
)
813 (let ((f1 (make-fpr 1)))
814 (inst lfd f1 sp
(- (* n-return-area-words n-word-bytes
)))))
815 ((sb!alien
::alien-void-type-p result-type
)
819 (loop with gprs
= (mapcar #'make-gpr
'(3 4))
820 repeat n-return-area-words
822 for offset from
(- (* n-return-area-words n-word-bytes
))
826 (bug "Out of return registers in alien-callback trampoline."))
827 (inst lwz gpr sp offset
))))
829 (finalize-segment segment
)
830 ;; Now that the segment is done, convert it to a static
831 ;; vector we can point foreign code to.
832 (let* ((buffer (sb!assem
::segment-buffer segment
))
833 (vector (make-static-vector (length buffer
)
834 :element-type
'(unsigned-byte 8)
835 :initial-contents buffer
))
836 (sap (vector-sap vector
)))
838 (extern-alien "ppc_flush_icache"