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 (defun 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 (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 (when (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
))))
240 (define-vop (foreign-symbol-dataref-sap)
241 (:translate foreign-symbol-dataref-sap
)
244 (:arg-types
(:constant simple-string
))
245 (:info foreign-symbol
)
246 (:results
(res :scs
(sap-reg)))
247 (:result-types system-area-pointer
)
248 (:temporary
(:scs
(non-descriptor-reg)) addr
)
250 (inst li addr
(make-fixup foreign-symbol
:foreign-dataref
))
253 (define-vop (call-out)
254 (:args
(function :scs
(sap-reg) :target cfunc
)
256 (:results
(results :more t
))
257 (:ignore args results
)
259 (:temporary
(:sc any-reg
:offset cfunc-offset
260 :from
(:argument
0) :to
(:result
0)) cfunc
)
261 (:temporary
(:sc control-stack
:offset nfp-save-offset
) nfp-save
)
264 (let ((cur-nfp (current-nfp-tn vop
)))
266 (store-stack-tn nfp-save cur-nfp
))
267 (inst jal
(make-fixup "call_into_c" :foreign
))
268 (move cfunc function t
)
270 (load-stack-tn cur-nfp nfp-save
)))))
272 (define-vop (alloc-number-stack-space)
274 (:result-types system-area-pointer
)
275 (:results
(result :scs
(sap-reg any-reg
)))
276 (:temporary
(:scs
(unsigned-reg) :to
(:result
0)) temp
)
278 (unless (zerop amount
)
279 (let ((delta (logandc2 (+ amount
7) 7)))
280 (cond ((< delta
(ash 1 15))
281 (inst subu nsp-tn delta
))
284 (inst subu nsp-tn temp
)))))
285 (move result nsp-tn
)))
287 (define-vop (dealloc-number-stack-space)
290 (:temporary
(:scs
(unsigned-reg) :to
(:result
0)) temp
)
292 (unless (zerop amount
)
293 (let ((delta (logandc2 (+ amount
7) 7)))
294 (cond ((< delta
(ash 1 15))
295 (inst addu nsp-tn delta
))
298 (inst addu nsp-tn temp
)))))))
301 (defun alien-callback-accessor-form (type sap offset
)
302 ;; KLUDGE: OFFSET is given to be word-aligned (32-bit aligned), but
303 ;; double-float and long-long (both 64-bit wide) arguments need to
304 ;; be 64-bit aligned. And then there's the bit where sub-word-wide
305 ;; values are aligned towards the END of the word on big-endian
306 ;; systems. For both cases, we need to parse the alien type, but we
307 ;; aren't given the environment that our caller has access to, so we
308 ;; substitute a null lexenv (KLUDGE number one), then we do some bit
309 ;; twiddling to determine how much alignment we need. Why, oh why
310 ;; can't we have something like the :ARG-TN methods for all of this
311 ;; mess? -- AB, 2015-Nov-02
312 (let* ((parsed-type (parse-alien-type type nil
))
313 (alignment-bits (sb!alien
::alien-type-alignment parsed-type
))
314 (alignment-bytes (truncate alignment-bits n-byte-bits
))
315 ;; OFFSET is at least 32-bit aligned, we're trying to pick
316 ;; out the cases where we need 64-bit alignment.
317 (delta (logand offset
(1- alignment-bytes
))))
319 (ecase *backend-byte-order
*
321 (if (alien-integer-type-p parsed-type
)
322 (let ((bits (sb!alien
::alien-integer-type-bits parsed-type
)))
324 (cond ((< bits n-word-bits
)
326 (ceiling bits n-byte-bits
)))
328 `(deref (sap-alien (sap+ ,sap
329 ,(+ byte-offset offset delta
))
331 `(deref (sap-alien (sap+ ,sap
,(+ offset delta
)) (* ,type
)))))
333 `(deref (sap-alien (sap+ ,sap
,(+ offset delta
)) (* ,type
)))))
336 ;;; Returns a vector in static space containing machine code for the
339 (defun alien-callback-assembler-wrapper (index result-type argument-types
)
340 "Cons up a piece of code which calls enter-alien-callback with INDEX
341 and a pointer to the arguments."
343 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'any-reg
) :offset n
))
345 (make-random-tn :kind
:normal
:sc
(sc-or-lose 'double-reg
) :offset n
)))
346 (let* ((segment (make-segment))
348 (mapcar (lambda (arg) (ceiling (alien-type-bits arg
) n-word-bits
))
350 (n-linkage-area-bytes 8)
352 (ceiling (or (alien-type-bits result-type
) 0) n-word-bits
))
353 (n-return-area-bytes (* n-return-area-words n-word-bytes
))
354 (n-callee-register-args-bytes 16)
355 (n-frame-bytes (logandc2 (+ n-linkage-area-bytes
357 n-callee-register-args-bytes
362 (gprs (mapcar #'make-gpr
'(4 5 6 7)))
363 (fprs (mapcar #'make-fpr
'(12 14))))
364 (flet ((save-arg (type words
)
365 (let ((offset (* words-processed n-word-bytes
)))
366 (cond ((not (alien-float-type-p type
))
367 (when (and (alien-integer-type-p type
)
368 (> (sb!alien
::alien-integer-type-bits type
)
370 (oddp words-processed
))
372 (incf words-processed
)
373 (incf offset n-word-bytes
))
378 (inst sw gpr nsp-tn offset
)
381 (incf words-processed
)
382 (incf offset n-word-bytes
))))
383 ((alien-single-float-type-p type
)
385 (let ((gpr (pop gprs
))
388 ((and (not int-seen
) fpr
)
389 (inst swc1 fpr nsp-tn offset
))
391 (inst sw gpr nsp-tn offset
))))
392 (incf words-processed
)))
393 ((alien-double-float-type-p type
)
394 (when (oddp words-processed
)
396 (incf words-processed
)
397 (incf offset n-word-bytes
))
399 (let* ((gpr1 (pop gprs
))
403 ((and (not int-seen
) fpr
)
404 (ecase *backend-byte-order
*
406 (inst swc1 fpr nsp-tn
(+ offset n-word-bytes
))
407 (inst swc1-odd fpr nsp-tn offset
))
409 (inst swc1 fpr nsp-tn offset
)
410 (inst swc1-odd fpr nsp-tn
(+ offset n-word-bytes
)))))
412 (ecase *backend-byte-order
*
414 (inst sw gpr1 nsp-tn offset
)
415 (inst sw gpr2 nsp-tn
(+ offset n-word-bytes
)))
417 (inst sw gpr2 nsp-tn offset
)
418 (inst sw gpr1 nsp-tn
(+ offset n-word-bytes
)))))))
419 (incf words-processed
2)))
421 (bug "Unknown alien floating point type: ~S" type
))))))
423 (mapc #'save-arg argument-types n-argument-words
)
424 ;; funcall3 (enter-alien-callback, index, args, return-area)
426 ;; INDEX is fixnumized, ARGS and RETURN-AREA don't need to be
427 ;; because they're word-aligned. Kinda gross, but hey ...
428 (destructuring-bind (v0 v1 a0 a1 a2 a3 t9 gp sp ra
)
429 (mapcar #'make-gpr
'(2 3 4 5 6 7 25 28 29 31))
430 ;; Allocate stack frame.
431 (inst subu sp n-frame-bytes
)
434 (inst sw gp sp
(- n-frame-bytes
(* 2 n-word-bytes
)))
435 (inst sw ra sp
(- n-frame-bytes n-word-bytes
))
437 ;; Setup the args and make the call.
438 (inst li a0
(static-fdefn-fun-addr 'enter-alien-callback
))
440 (inst li t9
(foreign-symbol-address "funcall3"))
441 (inst li a1
(fixnumize index
))
442 (inst addu a2 sp n-frame-bytes
)
444 (inst addu a3 sp n-callee-register-args-bytes
)
446 ;; We're back! Restore GP.
447 (inst lw gp sp
(- n-frame-bytes
(* 2 n-word-bytes
)))
449 ;; Load the return value.
451 ((alien-single-float-type-p result-type
)
452 (inst lwc1
(make-fpr 0) sp n-callee-register-args-bytes
))
453 ((alien-double-float-type-p result-type
)
454 (ecase *backend-byte-order
*
456 (inst lwc1
(make-fpr 0) sp
(+ n-callee-register-args-bytes
458 (inst lwc1
(make-fpr 1) sp n-callee-register-args-bytes
))
460 (inst lwc1
(make-fpr 0) sp n-callee-register-args-bytes
)
461 (inst lwc1
(make-fpr 1) sp
(+ n-callee-register-args-bytes
463 ((and (alien-integer-type-p result-type
)
464 (> (sb!alien
::alien-integer-type-bits result-type
)
466 (inst lw v0 sp n-callee-register-args-bytes
)
467 (inst lw v1 sp
(+ n-callee-register-args-bytes n-word-bytes
)))
468 ((or (alien-integer-type-p result-type
)
469 (alien-pointer-type-p result-type
)
470 (alien-type-= #.
(parse-alien-type 'system-area-pointer nil
)
472 (inst lw v0 sp n-callee-register-args-bytes
))
473 ((alien-void-type-p result-type
))
475 (error "unrecognized alien type: ~A" result-type
)))
477 ;; Restore RA, free stack frame, and return.
478 (inst lw ra sp
(- n-frame-bytes n-word-bytes
))
480 (inst addu sp n-frame-bytes
))))
481 (finalize-segment segment
)
482 ;; Now that the segment is done, convert it to a static
483 ;; vector we can point foreign code to.
484 (let* ((buffer (sb!assem
::segment-buffer segment
))
485 (vector (make-static-vector (length buffer
)
486 :element-type
'(unsigned-byte 8)
487 :initial-contents buffer
))
488 (sap (vector-sap vector
)))
490 (extern-alien "os_flush_icache"