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 (defun my-make-wired-tn (prim-type-name sc-name offset)
15 (make-wired-tn (primitive-type-or-lose prim-type-name)
16 (sc-number-or-lose sc-name)
24 (define-alien-type-method (integer :arg-tn) (type state)
25 (let ((stack-frame-size (arg-state-stack-frame-size state)))
26 (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
27 (setf (arg-state-did-int-arg state) t)
29 (ptype reg-sc stack-sc)
30 (if (alien-integer-type-signed type)
31 (values 'signed-byte-32 'signed-reg 'signed-stack)
32 (values 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))
33 (if (< stack-frame-size 4)
34 (my-make-wired-tn ptype reg-sc (+ stack-frame-size 4))
35 (my-make-wired-tn ptype stack-sc stack-frame-size)))))
37 (define-alien-type-method (system-area-pointer :arg-tn) (type state)
38 (declare (ignore type))
39 (let ((stack-frame-size (arg-state-stack-frame-size state)))
40 (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
41 (setf (arg-state-did-int-arg state) t)
42 (if (< stack-frame-size 4)
43 (my-make-wired-tn 'system-area-pointer
45 (+ stack-frame-size 4))
46 (my-make-wired-tn 'system-area-pointer
50 (define-alien-type-method (double-float :arg-tn) (type state)
51 (declare (ignore type))
52 (let ((stack-frame-size (logandc2 (1+ (arg-state-stack-frame-size state)) 1))
53 (float-args (arg-state-float-args state)))
54 (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
55 (setf (arg-state-float-args state) (1+ float-args))
56 (cond ((>= stack-frame-size 4)
57 (my-make-wired-tn 'double-float
60 ((and (not (arg-state-did-int-arg state))
62 (my-make-wired-tn 'double-float
64 (+ (* float-args 2) 12)))
66 (my-make-wired-tn 'double-float
68 (+ stack-frame-size 4))))))
70 (define-alien-type-method (single-float :arg-tn) (type state)
71 (declare (ignore type))
72 (let ((stack-frame-size (arg-state-stack-frame-size state))
73 (float-args (arg-state-float-args state)))
74 (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
75 (setf (arg-state-float-args state) (1+ float-args))
76 (cond ((>= stack-frame-size 4)
77 (my-make-wired-tn 'single-float
80 ((and (not (arg-state-did-int-arg state))
82 (my-make-wired-tn 'single-float
84 (+ (* float-args 2) 12)))
86 (my-make-wired-tn 'single-float
88 (+ stack-frame-size 4))))))
90 (defstruct result-state
93 (defun result-reg-offset (slot)
98 (define-alien-type-method (integer :result-tn) (type state)
99 (let ((num-results (result-state-num-results state)))
100 (setf (result-state-num-results state) (1+ num-results))
101 (multiple-value-bind (ptype reg-sc)
102 (if (alien-integer-type-signed type)
103 (values 'signed-byte-32 'signed-reg)
104 (values 'unsigned-byte-32 'unsigned-reg))
105 (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
107 (define-alien-type-method (system-area-pointer :result-tn) (type state)
108 (declare (ignore type))
109 (let ((num-results (result-state-num-results state)))
110 (setf (result-state-num-results state) (1+ num-results))
111 (my-make-wired-tn 'system-area-pointer 'sap-reg (result-reg-offset num-results))))
113 ;;; FIXME: do these still work? -- CSR, 2002-08-28
114 (define-alien-type-method (double-float :result-tn) (type state)
115 (declare (ignore type))
116 (let ((num-results (result-state-num-results state)))
117 (setf (result-state-num-results state) (1+ num-results))
118 (my-make-wired-tn 'double-float 'double-reg (* num-results 2))))
120 (define-alien-type-method (single-float :result-tn) (type state)
121 (declare (ignore type))
122 (let ((num-results (result-state-num-results state)))
123 (setf (result-state-num-results state) (1+ num-results))
124 (my-make-wired-tn 'single-float 'single-reg (* num-results 2))))
126 (define-alien-type-method (values :result-tn) (type state)
127 (let ((values (alien-values-type-values type)))
128 (when (> (length values) 2)
129 (error "Too many result values from c-call."))
130 (mapcar #'(lambda (type)
131 (invoke-alien-type-method :result-tn type state))
134 (!def-vm-support-routine make-call-out-tns (type)
135 (let ((arg-state (make-arg-state)))
137 (dolist (arg-type (alien-fun-type-arg-types type))
138 (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
139 (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
140 (* (max (arg-state-stack-frame-size arg-state) 4) n-word-bytes)
142 (invoke-alien-type-method :result-tn
143 (alien-fun-type-result-type type)
144 (make-result-state))))))
146 (deftransform %alien-funcall ((function type &rest args))
147 (aver (sb!c::constant-lvar-p type))
148 (let* ((type (sb!c::lvar-value type))
149 (env (sb!kernel:make-null-lexenv))
150 (arg-types (alien-fun-type-arg-types type))
151 (result-type (alien-fun-type-result-type type)))
152 (aver (= (length arg-types) (length args)))
153 ;; We need to do something special for 64-bit integer arguments
155 (if (or (some #'(lambda (type)
156 (and (alien-integer-type-p type)
157 (> (sb!alien::alien-integer-type-bits type) 32)))
159 (and (alien-integer-type-p result-type)
160 (> (sb!alien::alien-integer-type-bits result-type) 32)))
161 (collect ((new-args) (lambda-vars) (new-arg-types))
162 (dolist (type arg-types)
163 (let ((arg (gensym)))
165 (cond ((and (alien-integer-type-p type)
166 (> (sb!alien::alien-integer-type-bits type) 32))
167 ;; 64-bit long long types are stored in
168 ;; consecutive locations, endian word order,
169 ;; aligned to 8 bytes.
170 (if (oddp (length (new-args)))
173 (progn (new-args `(ash ,arg -32))
174 (new-args `(logand ,arg #xffffffff))
175 (if (oddp (length (new-arg-types)))
176 (new-arg-types (parse-alien-type '(unsigned 32) env)))
177 (if (alien-integer-type-signed type)
178 (new-arg-types (parse-alien-type '(signed 32) env))
179 (new-arg-types (parse-alien-type '(unsigned 32) env)))
180 (new-arg-types (parse-alien-type '(unsigned 32) env)))
182 (progn (new-args `(logand ,arg #xffffffff))
183 (new-args `(ash ,arg -32))
184 (if (oddp (length (new-arg-types)))
185 (new-arg-types (parse-alien-type '(unsigned 32) env)))
186 (new-arg-types (parse-alien-type '(unsigned 32) env))
187 (if (alien-integer-type-signed type)
188 (new-arg-types (parse-alien-type '(signed 32) env))
189 (new-arg-types (parse-alien-type '(unsigned 32) env)))))
192 (new-arg-types type)))))
193 (cond ((and (alien-integer-type-p result-type)
194 (> (sb!alien::alien-integer-type-bits result-type) 32))
195 (let ((new-result-type
196 (let ((sb!alien::*values-type-okay* t))
198 (if (alien-integer-type-signed result-type)
200 '(values (signed 32) (unsigned 32))
202 '(values (unsigned 32) (signed 32))
203 '(values (unsigned 32) (unsigned 32)))
205 `(lambda (function type ,@(lambda-vars))
206 (declare (ignore type))
212 (%alien-funcall function
213 ',(make-alien-fun-type
214 :arg-types (new-arg-types)
215 :result-type new-result-type)
217 (logior low (ash high 32))))))
219 `(lambda (function type ,@(lambda-vars))
220 (declare (ignore type))
221 (%alien-funcall function
222 ',(make-alien-fun-type
223 :arg-types (new-arg-types)
224 :result-type result-type)
226 (sb!c::give-up-ir1-transform))))
228 (define-vop (foreign-symbol-sap)
229 (:translate foreign-symbol-sap)
232 (:arg-types (:constant simple-string))
233 (:info foreign-symbol)
234 (:results (res :scs (sap-reg)))
235 (:result-types system-area-pointer)
237 (inst li res (make-fixup foreign-symbol :foreign))))
239 (define-vop (call-out)
240 (:args (function :scs (sap-reg) :target cfunc)
242 (:results (results :more t))
243 (:ignore args results)
245 (:temporary (:sc any-reg :offset cfunc-offset
246 :from (:argument 0) :to (:result 0)) cfunc)
247 (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
250 (let ((cur-nfp (current-nfp-tn vop)))
252 (store-stack-tn nfp-save cur-nfp))
253 (inst jal (make-fixup "call_into_c" :foreign))
254 (move cfunc function t)
256 (load-stack-tn cur-nfp nfp-save)))))
258 (define-vop (alloc-number-stack-space)
260 (:results (result :scs (sap-reg any-reg)))
261 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
263 (unless (zerop amount)
264 (let ((delta (logandc2 (+ amount 7) 7)))
265 (cond ((< delta (ash 1 15))
266 (inst subu nsp-tn delta))
269 (inst subu nsp-tn temp)))))
270 (move result nsp-tn)))
272 (define-vop (dealloc-number-stack-space)
275 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
277 (unless (zerop amount)
278 (let ((delta (logandc2 (+ amount 7) 7)))
279 (cond ((< delta (ash 1 15))
280 (inst addu nsp-tn delta))
283 (inst addu nsp-tn temp)))))))