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 )
22 (def-alien-type-method (integer :arg-tn) (type state)
23 (let ((stack-frame-size (arg-state-stack-frame-size state)))
24 (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
26 (ptype reg-sc stack-sc)
27 (if (alien-integer-type-signed type)
28 (values 'signed-byte-64 'signed-reg 'signed-stack)
29 (values 'unsigned-byte-64 'unsigned-reg 'unsigned-stack))
30 (if (< stack-frame-size 4)
31 (my-make-wired-tn ptype reg-sc (+ stack-frame-size nl0-offset))
32 (my-make-wired-tn ptype stack-sc (* 2 (- stack-frame-size 4)))))))
34 (def-alien-type-method (system-area-pointer :arg-tn) (type state)
35 (declare (ignore type))
36 (let ((stack-frame-size (arg-state-stack-frame-size state)))
37 (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
38 (if (< stack-frame-size 4)
39 (my-make-wired-tn 'system-area-pointer
41 (+ stack-frame-size nl0-offset))
42 (my-make-wired-tn 'system-area-pointer
44 (* 2 (- stack-frame-size 4))))))
46 (def-alien-type-method (double-float :arg-tn) (type state)
47 (declare (ignore type))
48 (let ((stack-frame-size (arg-state-stack-frame-size state)))
49 (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
50 (if (< stack-frame-size 6)
51 (my-make-wired-tn 'double-float
53 (+ stack-frame-size nl0-offset))
54 (my-make-wired-tn 'double-float
56 (* 2 (- stack-frame-size 6))))))
58 (def-alien-type-method (single-float :arg-tn) (type state)
59 (declare (ignore type))
60 (let ((stack-frame-size (arg-state-stack-frame-size state)))
61 (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
62 (if (< stack-frame-size 6)
63 (my-make-wired-tn 'single-float
65 (+ stack-frame-size nl0-offset))
66 (my-make-wired-tn 'single-float
68 (* 2 (- stack-frame-size 6))))))
72 (def-alien-type-method (integer :result-tn) (type state)
73 (declare (ignore state))
76 (if (alien-integer-type-signed type)
77 (values 'signed-byte-64 'signed-reg)
78 (values 'unsigned-byte-64 'unsigned-reg))
79 (my-make-wired-tn ptype reg-sc lip-offset)))
81 (def-alien-type-method (system-area-pointer :result-tn) (type state)
82 (declare (ignore type state))
83 (my-make-wired-tn 'system-area-pointer 'sap-reg lip-offset))
85 (def-alien-type-method (double-float :result-tn) (type state)
86 (declare (ignore type state))
87 (my-make-wired-tn 'double-float 'double-reg lip-offset))
89 (def-alien-type-method (single-float :result-tn) (type state)
90 (declare (ignore type state))
91 (my-make-wired-tn 'single-float 'single-reg lip-offset))
93 (def-alien-type-method (values :result-tn) (type state)
94 (let ((values (alien-values-type-values type)))
96 (error "Too many result values from c-call."))
98 (invoke-alien-type-method :result-tn (car values) state))))
100 (!def-vm-support-routine make-call-out-tns (type)
101 (let ((arg-state (make-arg-state)))
103 (dolist (arg-type (alien-function-type-arg-types type))
104 (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
105 (values (my-make-wired-tn 'positive-fixnum 'any-reg nsp-offset)
106 (* (max (arg-state-stack-frame-size arg-state) 4) word-bytes)
108 (invoke-alien-type-method :result-tn
109 (alien-function-type-result-type type)
112 (define-vop (foreign-symbol-address)
113 (:translate foreign-symbol-address)
116 (:arg-types (:constant simple-string))
117 (:info foreign-symbol)
118 (:results (res :scs (sap-reg)))
119 (:result-types system-area-pointer)
121 (inst li (make-fixup foreign-symbol :foreign) res)))
123 (define-vop (call-out)
124 (:args (function :scs (sap-reg) :target cfunc)
126 (:results (results :more t))
127 (:ignore args results)
129 (:temporary (:sc any-reg :offset cfunc-offset
130 :from (:argument 0) :to (:result 0)) cfunc)
131 (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
132 (:temporary (:scs (non-descriptor-reg)) temp)
135 (let ((cur-nfp (sb!c::current-nfp-tn vop)))
137 (store-stack-tn nfp-save cur-nfp))
138 (move function cfunc)
139 (inst li (make-fixup "call_into_c" :foreign) temp)
140 (inst jsr lip-tn temp (make-fixup "call_into_c" :foreign))
142 (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))))
144 (define-vop (alloc-number-stack-space)
146 (:results (result :scs (sap-reg any-reg)))
147 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
149 (unless (zerop amount)
150 (let ((delta (logandc2 (+ amount 7) 7)))
151 (cond ((< delta (ash 1 15))
152 (inst lda nsp-tn (- delta) nsp-tn))
155 (inst subq nsp-tn temp nsp-tn)))))
156 (move nsp-tn result)))
158 (define-vop (dealloc-number-stack-space)
161 (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
163 (unless (zerop amount)
164 (let ((delta (logandc2 (+ amount 7) 7)))
165 (cond ((< delta (ash 1 15))
166 (inst lda nsp-tn delta nsp-tn))
169 (inst addq nsp-tn temp nsp-tn)))))))