1 ;;;; the VOPs and other necessary machine specific support
2 ;;;; routines for call-out to C
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
15 ;; The MOVE-ARG vop is going to store args on the stack for
16 ;; call-out. These tn's will be used for that. move-arg is normally
17 ;; used for things going down the stack but C wants to have args
18 ;; indexed in the positive direction.
20 (defun my-make-wired-tn (prim-type-name sc-name offset
)
21 (make-wired-tn (primitive-type-or-lose prim-type-name
)
22 (sc-number-or-lose sc-name
)
25 (defstruct (arg-state (:copier nil
))
30 (defun int-arg (state prim-type reg-sc stack-sc
)
31 (let ((reg-args (arg-state-register-args state
)))
33 (setf (arg-state-register-args state
) (1+ reg-args
))
34 (my-make-wired-tn prim-type reg-sc
35 (nth reg-args
*c-call-register-arg-offsets
*)))
37 (let ((frame-size (arg-state-stack-frame-size state
)))
38 (setf (arg-state-stack-frame-size state
) (1+ frame-size
))
39 (my-make-wired-tn prim-type stack-sc frame-size
))))))
41 (define-alien-type-method (integer :arg-tn
) (type state
)
42 (if (alien-integer-type-signed type
)
43 (int-arg state
'signed-byte-64
'signed-reg
'signed-stack
)
44 (int-arg state
'unsigned-byte-64
'unsigned-reg
'unsigned-stack
)))
46 (define-alien-type-method (system-area-pointer :arg-tn
) (type state
)
47 (declare (ignore type
))
48 (int-arg state
'system-area-pointer
'sap-reg
'sap-stack
))
50 (defun float-arg (state prim-type reg-sc stack-sc
)
51 (let ((xmm-args (arg-state-xmm-args state
)))
53 (setf (arg-state-xmm-args state
) (1+ xmm-args
))
54 (my-make-wired-tn prim-type reg-sc
55 (nth xmm-args
*float-regs
*)))
57 (let ((frame-size (arg-state-stack-frame-size state
)))
58 (setf (arg-state-stack-frame-size state
) (1+ frame-size
))
59 (my-make-wired-tn prim-type stack-sc frame-size
))))))
61 (define-alien-type-method (double-float :arg-tn
) (type state
)
62 (declare (ignore type
))
63 (float-arg state
'double-float
'double-reg
'double-stack
))
65 (define-alien-type-method (single-float :arg-tn
) (type state
)
66 (declare (ignore type
))
67 (float-arg state
'single-float
'single-reg
'single-stack
))
69 (defstruct (result-state (:copier nil
))
72 (defun result-reg-offset (slot)
77 ;; XXX The return handling probably doesn't conform to the ABI
79 (define-alien-type-method (integer :result-tn
) (type state
)
80 (let ((num-results (result-state-num-results state
)))
81 (setf (result-state-num-results state
) (1+ num-results
))
82 (multiple-value-bind (ptype reg-sc
)
83 (if (alien-integer-type-signed type
)
84 (values (if (= (sb!alien
::alien-integer-type-bits type
) 32)
88 (values 'unsigned-byte-64
'unsigned-reg
))
89 (my-make-wired-tn ptype reg-sc
(result-reg-offset num-results
)))))
91 (define-alien-type-method (system-area-pointer :result-tn
) (type state
)
92 (declare (ignore type
))
93 (let ((num-results (result-state-num-results state
)))
94 (setf (result-state-num-results state
) (1+ num-results
))
95 (my-make-wired-tn 'system-area-pointer
'sap-reg
96 (result-reg-offset num-results
))))
98 (define-alien-type-method (double-float :result-tn
) (type state
)
99 (declare (ignore type
))
100 (let ((num-results (result-state-num-results state
)))
101 (setf (result-state-num-results state
) (1+ num-results
))
102 (my-make-wired-tn 'double-float
'double-reg num-results
)))
104 (define-alien-type-method (single-float :result-tn
) (type state
)
105 (declare (ignore type
))
106 (let ((num-results (result-state-num-results state
)))
107 (setf (result-state-num-results state
) (1+ num-results
))
108 (my-make-wired-tn 'single-float
'single-reg num-results
)))
110 (define-alien-type-method (values :result-tn
) (type state
)
111 (let ((values (alien-values-type-values type
)))
112 (when (> (length values
) 2)
113 (error "Too many result values from c-call."))
114 (mapcar (lambda (type)
115 (invoke-alien-type-method :result-tn type state
))
118 (!def-vm-support-routine make-call-out-tns
(type)
119 (let ((arg-state (make-arg-state)))
121 (dolist (arg-type (alien-fun-type-arg-types type
))
122 (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state
)))
123 (values (my-make-wired-tn 'positive-fixnum
'any-reg esp-offset
)
124 (* (arg-state-stack-frame-size arg-state
) n-word-bytes
)
126 (invoke-alien-type-method :result-tn
127 (alien-fun-type-result-type type
)
128 (make-result-state))))))
131 (deftransform %alien-funcall
((function type
&rest args
) * * :node node
)
132 (aver (sb!c
::constant-lvar-p type
))
133 (let* ((type (sb!c
::lvar-value type
))
134 (env (sb!c
::node-lexenv node
))
135 (arg-types (alien-fun-type-arg-types type
))
136 (result-type (alien-fun-type-result-type type
)))
137 (aver (= (length arg-types
) (length args
)))
138 (if (or (some #'(lambda (type)
139 (and (alien-integer-type-p type
)
140 (> (sb!alien
::alien-integer-type-bits type
) 64)))
142 (and (alien-integer-type-p result-type
)
143 (> (sb!alien
::alien-integer-type-bits result-type
) 64)))
144 (collect ((new-args) (lambda-vars) (new-arg-types))
145 (dolist (type arg-types
)
146 (let ((arg (gensym)))
148 (cond ((and (alien-integer-type-p type
)
149 (> (sb!alien
::alien-integer-type-bits type
) 64))
150 (new-args `(logand ,arg
#xffffffff
))
151 (new-args `(ash ,arg -
64))
152 (new-arg-types (parse-alien-type '(unsigned 64) env
))
153 (if (alien-integer-type-signed type
)
154 (new-arg-types (parse-alien-type '(signed 64) env
))
155 (new-arg-types (parse-alien-type '(unsigned 64) env
))))
158 (new-arg-types type
)))))
159 (cond ((and (alien-integer-type-p result-type
)
160 (> (sb!alien
::alien-integer-type-bits result-type
) 64))
161 (let ((new-result-type
162 (let ((sb!alien
::*values-type-okay
* t
))
164 (if (alien-integer-type-signed result-type
)
165 '(values (unsigned 64) (signed 64))
166 '(values (unsigned 64) (unsigned 64)))
168 `(lambda (function type
,@(lambda-vars))
169 (declare (ignore type
))
170 (multiple-value-bind (low high
)
171 (%alien-funcall function
172 ',(make-alien-fun-type
173 :arg-types
(new-arg-types)
174 :result-type new-result-type
)
176 (logior low
(ash high
64))))))
178 `(lambda (function type
,@(lambda-vars))
179 (declare (ignore type
))
180 (%alien-funcall function
181 ',(make-alien-fun-type
182 :arg-types
(new-arg-types)
183 :result-type result-type
)
185 (sb!c
::give-up-ir1-transform
))))
190 (define-vop (foreign-symbol-address)
191 (:translate foreign-symbol-address
)
194 (:arg-types
(:constant simple-string
))
195 (:info foreign-symbol
)
196 (:results
(res :scs
(sap-reg)))
197 (:result-types system-area-pointer
)
199 (inst lea res
(make-fixup (extern-alien-name foreign-symbol
) :foreign
))))
202 (define-vop (foreign-symbol-dataref-address)
203 (:translate foreign-symbol-dataref-address
)
206 (:arg-types
(:constant simple-string
))
207 (:info foreign-symbol
)
208 (:results
(res :scs
(sap-reg)))
209 (:result-types system-area-pointer
)
211 (inst mov res
(make-fixup (extern-alien-name foreign-symbol
) :foreign-dataref
))))
213 (define-vop (call-out)
214 (:args
(function :scs
(sap-reg))
216 (:results
(results :more t
))
217 (:temporary
(:sc unsigned-reg
:offset rax-offset
:to
:result
) rax
)
218 (:temporary
(:sc unsigned-reg
:offset rcx-offset
219 :from
:eval
:to
:result
) rcx
)
223 ;; ABI: AL contains amount of arguments passed in XMM registers
226 (loop for tn-ref
= args then
(tn-ref-across tn-ref
)
228 count
(eq (sb-name (sc-sb (tn-sc (tn-ref-tn tn-ref
))))
231 ;; To give the debugger a clue. XX not really internal-error?
232 (note-this-location vop
:internal-error
)
233 ;; Sign-extend s-b-32 return values.
234 (dolist (res (if (listp results
)
237 (let ((tn (tn-ref-tn res
)))
238 (when (eq (sb!c
::tn-primitive-type tn
)
239 (primitive-type-or-lose 'signed-byte-32
))
240 (inst movsxd tn
(make-random-tn :kind
:normal
241 :sc
(sc-or-lose 'dword-reg
)
242 :offset
(tn-offset tn
))))))
243 ;; FLOAT15 needs to contain FP zero in Lispland
245 (inst movd
(make-random-tn :kind
:normal
246 :sc
(sc-or-lose 'double-reg
)
247 :offset float15-offset
)
250 (define-vop (alloc-number-stack-space)
252 (:results
(result :scs
(sap-reg any-reg
)))
254 (aver (location= result rsp-tn
))
255 (unless (zerop amount
)
256 (let ((delta (logandc2 (+ amount
3) 3)))
257 (inst sub rsp-tn delta
)))
258 (move result rsp-tn
)))
260 (define-vop (dealloc-number-stack-space)
263 (unless (zerop amount
)
264 (let ((delta (logandc2 (+ amount
3) 3)))
265 (inst add rsp-tn delta
)))))
267 (define-vop (alloc-alien-stack-space)
269 #!+sb-thread
(:temporary
(:sc unsigned-reg
) temp
)
270 (:results
(result :scs
(sap-reg any-reg
)))
273 (aver (not (location= result rsp-tn
)))
274 (unless (zerop amount
)
275 (let ((delta (logandc2 (+ amount
3) 3)))
279 (static-symbol-offset '*alien-stack
*)
280 (ash symbol-tls-index-slot word-shift
)
281 (- other-pointer-lowtag
))))
282 (inst fs-segment-prefix
)
283 (inst sub
(make-ea :dword
:scale
1 :index temp
) delta
)))
284 (load-tl-symbol-value result
*alien-stack
*))
287 (aver (not (location= result rsp-tn
)))
288 (unless (zerop amount
)
289 (let ((delta (logandc2 (+ amount
3) 3)))
290 (inst sub
(make-ea :qword
292 (static-symbol-offset '*alien-stack
*)
293 (ash symbol-value-slot word-shift
)
294 (- other-pointer-lowtag
)))
296 (load-symbol-value result
*alien-stack
*)))
298 (define-vop (dealloc-alien-stack-space)
300 #!+sb-thread
(:temporary
(:sc unsigned-reg
) temp
)
303 (unless (zerop amount
)
304 (let ((delta (logandc2 (+ amount
3) 3)))
308 (static-symbol-offset '*alien-stack
*)
309 (ash symbol-tls-index-slot word-shift
)
310 (- other-pointer-lowtag
))))
311 (inst fs-segment-prefix
)
312 (inst add
(make-ea :dword
:scale
1 :index temp
) delta
))))
315 (unless (zerop amount
)
316 (let ((delta (logandc2 (+ amount
3) 3)))
317 (inst add
(make-ea :qword
319 (static-symbol-offset '*alien-stack
*)
320 (ash symbol-value-slot word-shift
)
321 (- other-pointer-lowtag
)))
324 ;;; these are not strictly part of the c-call convention, but are
325 ;;; needed for the WITH-PRESERVED-POINTERS macro used for "locking
326 ;;; down" lisp objects so that GC won't move them while foreign
327 ;;; functions go to work.
329 (define-vop (push-word-on-c-stack)
330 (:translate push-word-on-c-stack
)
331 (:args
(val :scs
(sap-reg)))
333 (:arg-types system-area-pointer
)
337 (define-vop (pop-words-from-c-stack)
338 (:translate pop-words-from-c-stack
)
340 (:arg-types
(:constant
(unsigned-byte 60)))
344 (inst add rsp-tn
(fixnumize number
))))