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
)
21 ;; No matter what we have to allocate at least 7 stack frame slots. One
22 ;; because the C call convention requries it, and 6 because whoever we call
23 ;; is going to expect to be able to save his 6 register arguments there.
26 (defun int-arg (state prim-type reg-sc stack-sc
)
27 (let ((reg-args (arg-state-register-args state
)))
29 (setf (arg-state-register-args state
) (1+ reg-args
))
30 (my-make-wired-tn prim-type reg-sc
(+ reg-args nl0-offset
)))
32 (let ((frame-size (arg-state-stack-frame-size state
)))
33 (setf (arg-state-stack-frame-size state
) (1+ frame-size
))
34 (my-make-wired-tn prim-type stack-sc
(+ frame-size
16)))))))
36 (define-alien-type-method (integer :arg-tn
) (type state
)
37 (if (alien-integer-type-signed type
)
38 (int-arg state
'signed-byte-32
'signed-reg
'signed-stack
)
39 (int-arg state
'unsigned-byte-32
'unsigned-reg
'unsigned-stack
)))
41 (define-alien-type-method (system-area-pointer :arg-tn
) (type state
)
42 (declare (ignore type
))
43 (int-arg state
'system-area-pointer
'sap-reg
'sap-stack
))
45 (defstruct result-state
48 (defun result-reg-offset (slot)
53 (define-alien-type-method (integer :result-tn
) (type state
)
54 (let ((num-results (result-state-num-results state
)))
55 (setf (result-state-num-results state
) (1+ num-results
))
56 (multiple-value-bind (ptype reg-sc
)
57 (if (alien-integer-type-signed type
)
58 (values 'signed-byte-32
'signed-reg
)
59 (values 'unsigned-byte-32
'unsigned-reg
))
60 (my-make-wired-tn ptype reg-sc
(result-reg-offset num-results
)))))
62 (define-alien-type-method (system-area-pointer :result-tn
) (type state
)
63 (declare (ignore type
))
64 (let ((num-results (result-state-num-results state
)))
65 (setf (result-state-num-results state
) (1+ num-results
))
66 (my-make-wired-tn 'system-area-pointer
'sap-reg
67 (result-reg-offset num-results
))))
69 (define-alien-type-method (double-float :result-tn
) (type state
)
70 (declare (ignore type state
))
71 (my-make-wired-tn 'double-float
'double-reg
0))
73 (define-alien-type-method (single-float :result-tn
) (type state
)
74 (declare (ignore type state
))
75 (my-make-wired-tn 'single-float
'single-reg
0))
78 (define-alien-type-method (long-float :result-tn
) (type)
79 (declare (ignore type
))
80 (my-make-wired-tn 'long-float
'long-reg
0))
82 (define-alien-type-method (values :result-tn
) (type state
)
83 (let ((values (alien-values-type-values type
)))
84 (when (> (length values
) 2)
85 (error "Too many result values from c-call."))
86 (mapcar #'(lambda (type)
87 (invoke-alien-type-method :result-tn type state
))
90 (defun make-call-out-tns (type)
91 (declare (type alien-fun-type type
))
92 (let ((arg-state (make-arg-state)))
94 (dolist (arg-type (alien-fun-type-arg-types type
))
95 (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state
)))
96 (values (my-make-wired-tn 'positive-fixnum
'any-reg nsp-offset
)
97 (* (arg-state-stack-frame-size arg-state
) n-word-bytes
)
99 (invoke-alien-type-method
101 (alien-fun-type-result-type type
)
102 (make-result-state))))))
104 (deftransform %alien-funcall
((function type
&rest args
))
105 (aver (sb!c
::constant-lvar-p type
))
106 (let* ((type (sb!c
::lvar-value type
))
107 (arg-types (alien-fun-type-arg-types type
))
108 (result-type (alien-fun-type-result-type type
)))
109 (aver (= (length arg-types
) (length args
)))
110 ;; We need to do something special for the following argument
111 ;; types: single-float, double-float, and 64-bit integers. For
112 ;; results, we need something special for 64-bit integer results.
113 (if (or (some #'alien-single-float-type-p arg-types
)
114 (some #'alien-double-float-type-p arg-types
)
115 (some #'(lambda (type)
116 (and (alien-integer-type-p type
)
117 (> (sb!alien
::alien-integer-type-bits type
) 32)))
119 #!+long-float
(some #'alien-long-float-type-p arg-types
)
120 (and (alien-integer-type-p result-type
)
121 (> (sb!alien
::alien-integer-type-bits result-type
) 32)))
122 (collect ((new-args) (lambda-vars) (new-arg-types))
123 (dolist (type arg-types
)
124 (let ((arg (gensym)))
126 (cond ((and (alien-integer-type-p type
)
127 (> (sb!alien
::alien-integer-type-bits type
) 32))
128 ;; 64-bit long long types are stored in
129 ;; consecutive locations, most significant word
130 ;; first (big-endian).
131 (new-args `(ash ,arg -
32))
132 (new-args `(logand ,arg
#xffffffff
))
133 (if (alien-integer-type-signed type
)
134 (new-arg-types (parse-alien-type '(signed 32) nil
))
135 (new-arg-types (parse-alien-type '(unsigned 32) nil
)))
136 (new-arg-types (parse-alien-type '(unsigned 32) nil
)))
137 ((alien-single-float-type-p type
)
138 (new-args `(single-float-bits ,arg
))
139 (new-arg-types (parse-alien-type '(signed 32) nil
)))
140 ((alien-double-float-type-p type
)
141 (new-args `(double-float-high-bits ,arg
))
142 (new-args `(double-float-low-bits ,arg
))
143 (new-arg-types (parse-alien-type '(signed 32) nil
))
144 (new-arg-types (parse-alien-type '(unsigned 32) nil
)))
146 ((alien-long-float-type-p type
)
147 (new-args `(long-float-exp-bits ,arg
))
148 (new-args `(long-float-high-bits ,arg
))
149 (new-args `(long-float-mid-bits ,arg
))
150 (new-args `(long-float-low-bits ,arg
))
151 (new-arg-types (parse-alien-type '(signed 32) nil
))
152 (new-arg-types (parse-alien-type '(unsigned 32) nil
))
153 (new-arg-types (parse-alien-type '(unsigned 32) nil
))
154 (new-arg-types (parse-alien-type '(unsigned 32) nil
)))
157 (new-arg-types type
)))))
158 (cond ((and (alien-integer-type-p result-type
)
159 (> (sb!alien
::alien-integer-type-bits result-type
) 32))
160 (let ((new-result-type
161 (let ((sb!alien
::*values-type-okay
* t
))
163 (if (alien-integer-type-signed result-type
)
164 '(values (signed 32) (unsigned 32))
165 '(values (unsigned 32) (unsigned 32)))
167 `(lambda (function type
,@(lambda-vars))
168 (declare (ignore type
))
169 (multiple-value-bind (high low
)
170 (%alien-funcall function
171 ',(make-alien-fun-type
172 :arg-types
(new-arg-types)
173 :result-type new-result-type
)
175 (logior low
(ash high
32))))))
177 `(lambda (function type
,@(lambda-vars))
178 (declare (ignore type
))
179 (%alien-funcall function
180 ',(make-alien-fun-type
181 :arg-types
(new-arg-types)
182 :result-type result-type
)
184 (sb!c
::give-up-ir1-transform
))))
186 (define-vop (foreign-symbol-sap)
187 (:translate foreign-symbol-sap
)
190 (:arg-types
(:constant simple-string
))
191 (:info foreign-symbol
)
192 (:results
(res :scs
(sap-reg)))
193 (:result-types system-area-pointer
)
195 (inst li res
(make-fixup foreign-symbol
:foreign
))))
198 (define-vop (foreign-symbol-dataref-sap)
199 (:translate foreign-symbol-dataref-sap
)
202 (:arg-types
(:constant simple-string
))
203 (:info foreign-symbol
)
204 (:results
(res :scs
(sap-reg)))
205 (:result-types system-area-pointer
)
206 (:temporary
(:scs
(non-descriptor-reg)) addr
)
208 (inst li addr
(make-fixup foreign-symbol
:foreign-dataref
))
211 (define-vop (call-out)
212 (:args
(function :scs
(sap-reg) :target cfunc
)
214 (:results
(results :more t
))
215 (:ignore args results
)
217 (:temporary
(:sc any-reg
:offset cfunc-offset
218 :from
(:argument
0) :to
(:result
0)) cfunc
)
219 (:temporary
(:sc interior-reg
:offset lip-offset
) lip
)
220 (:temporary
(:scs
(any-reg) :to
(:result
0)) temp
)
221 (:temporary
(:sc control-stack
:offset nfp-save-offset
) nfp-save
)
224 (let ((cur-nfp (current-nfp-tn vop
)))
226 (store-stack-tn nfp-save cur-nfp
))
227 (move cfunc function
)
228 (inst li temp
(make-fixup "call_into_c" :foreign
))
232 (load-stack-tn cur-nfp nfp-save
)))))
235 (define-vop (alloc-number-stack-space)
237 (:results
(result :scs
(sap-reg any-reg
)))
238 (:result-types system-area-pointer
)
239 (:temporary
(:scs
(unsigned-reg) :to
(:result
0)) temp
)
241 (unless (zerop amount
)
242 (let ((delta (logandc2 (+ amount
7) 7)))
243 (cond ((< delta
(ash 1 12))
244 (inst sub nsp-tn delta
))
247 (inst sub nsp-tn temp
)))))
248 (unless (location= result nsp-tn
)
249 ;; They are only location= when the result tn was allocated by
250 ;; make-call-out-tns above, which takes the number-stack-displacement
251 ;; into account itself.
252 (inst add result nsp-tn number-stack-displacement
))))
254 (define-vop (dealloc-number-stack-space)
257 (:temporary
(:scs
(unsigned-reg) :to
(:result
0)) temp
)
259 (unless (zerop amount
)
260 (let ((delta (logandc2 (+ amount
7) 7)))
261 (cond ((< delta
(ash 1 12))
262 (inst add nsp-tn delta
))
265 (inst add nsp-tn temp
)))))))