1 ;;; routines for call-out to C.
3 ;;; Written by William Lott.
7 (defun my-make-wired-tn (prim-type-name sc-name offset)
8 (make-wired-tn (primitive-type-or-lose prim-type-name)
9 (sc-number-or-lose sc-name)
15 ;SVR4 [a]abi wants two words on stack (callee saved lr, backpointer).
18 (defun int-arg (state prim-type reg-sc stack-sc)
19 (let ((reg-args (arg-state-gpr-args state)))
21 (setf (arg-state-gpr-args state) (1+ reg-args))
22 (my-make-wired-tn prim-type reg-sc (+ reg-args nl0-offset)))
24 (let ((frame-size (arg-state-stack-frame-size state)))
25 (setf (arg-state-stack-frame-size state) (1+ frame-size))
26 (my-make-wired-tn prim-type stack-sc frame-size))))))
28 (define-alien-type-method (integer :arg-tn) (type state)
29 (if (alien-integer-type-signed type)
30 (int-arg state 'signed-byte-32 'signed-reg 'signed-stack)
31 (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))
33 (define-alien-type-method (system-area-pointer :arg-tn) (type state)
34 (declare (ignore type))
35 (int-arg state 'system-area-pointer 'sap-reg 'sap-stack))
37 ; If a single-float arg has to go on the stack, it's promoted to
38 ; double. That way, C programs can get subtle rounding errors
39 ; when unrelated arguments are introduced.
41 (define-alien-type-method (single-float :arg-tn) (type state)
42 (declare (ignore type))
43 (let* ((fprs (arg-state-fpr-args state)))
45 (incf (arg-state-fpr-args state))
46 ; Assign outgoing FPRs starting at FP1
47 (my-make-wired-tn 'single-float 'single-reg (1+ fprs)))
49 (let* ((stack-offset (arg-state-stack-frame-size state)))
50 (if (oddp stack-offset)
52 (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
53 (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
55 (define-alien-type-method (double-float :arg-tn) (type state)
56 (declare (ignore type))
57 (let* ((fprs (arg-state-fpr-args state)))
59 (incf (arg-state-fpr-args state))
60 ; Assign outgoing FPRs starting at FP1
61 (my-make-wired-tn 'double-float 'double-reg (1+ fprs)))
63 (let* ((stack-offset (arg-state-stack-frame-size state)))
64 (if (oddp stack-offset)
66 (setf (arg-state-stack-frame-size state) (+ stack-offset 2))
67 (my-make-wired-tn 'double-float 'double-stack stack-offset))))))
69 (define-alien-type-method (integer :result-tn) (type)
70 (if (alien-integer-type-signed type)
71 (my-make-wired-tn 'signed-byte-32 'signed-reg nl0-offset)
72 (my-make-wired-tn 'unsigned-byte-32 'unsigned-reg nl0-offset)))
75 (define-alien-type-method (system-area-pointer :result-tn) (type)
76 (declare (ignore type))
77 (my-make-wired-tn 'system-area-pointer 'sap-reg nl0-offset))
79 (define-alien-type-method (single-float :result-tn) (type)
80 (declare (ignore type))
81 (my-make-wired-tn 'single-float 'single-reg 1))
83 (define-alien-type-method (double-float :result-tn) (type)
84 (declare (ignore type))
85 (my-make-wired-tn 'double-float 'double-reg 1))
87 (define-alien-type-method (values :result-tn) (type)
88 (mapcar #'(lambda (type)
89 (invoke-alien-type-method :result-tn type))
90 (alien-values-type-values type)))
93 (!def-vm-support-routine make-call-out-tns (type)
94 (declare (type alien-fun-type type))
95 (let ((arg-state (make-arg-state)))
97 (dolist (arg-type (alien-fun-type-arg-types type))
98 (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
99 (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
100 (* (arg-state-stack-frame-size arg-state) n-word-bytes)
102 (invoke-alien-type-method
104 (alien-fun-type-result-type type))))))
107 (define-vop (foreign-symbol-address)
108 (:translate foreign-symbol-address)
111 (:arg-types (:constant simple-string))
112 (:info foreign-symbol)
113 (:results (res :scs (sap-reg)))
114 (:result-types system-area-pointer)
116 (inst lr res (make-fixup foreign-symbol :foreign))))
118 (define-vop (call-out)
119 (:args (function :scs (sap-reg) :target cfunc)
121 (:results (results :more t))
122 (:ignore args results)
124 (:temporary (:sc any-reg :offset cfunc-offset
125 :from (:argument 0) :to (:result 0)) cfunc)
126 (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
127 (:temporary (:scs (non-descriptor-reg)) temp)
130 (let ((cur-nfp (current-nfp-tn vop)))
132 (store-stack-tn nfp-save cur-nfp))
133 (inst lr temp (make-fixup "call_into_c" :foreign))
135 (move cfunc function)
138 (load-stack-tn cur-nfp nfp-save)))))
141 (define-vop (alloc-number-stack-space)
143 (:results (result :scs (sap-reg any-reg)))
144 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
146 (unless (zerop amount)
147 (let ((delta (- (logandc2 (+ amount 8 7) 7))))
148 (cond ((>= delta (ash -1 16))
149 (inst stwu nsp-tn nsp-tn delta))
152 (inst stwux nsp-tn nsp-tn temp)))))
153 (unless (location= result nsp-tn)
154 ;; They are only location= when the result tn was allocated by
155 ;; make-call-out-tns above, which takes the number-stack-displacement
156 ;; into account itself.
157 (inst addi result nsp-tn number-stack-displacement))))
159 (define-vop (dealloc-number-stack-space)
163 (unless (zerop amount)
164 (let ((delta (logandc2 (+ amount 8 7) 7)))
165 (cond ((< delta (ash 1 16))
166 (inst addi nsp-tn nsp-tn delta))
168 (inst lwz nsp-tn nsp-tn 0)))))))