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
))
28 (define-alien-type-method (integer :arg-tn
) (type state
)
29 (let ((stack-frame-size (arg-state-stack-frame-size state
)))
30 (setf (arg-state-stack-frame-size state
) (1+ stack-frame-size
))
31 (multiple-value-bind (ptype stack-sc
)
32 (if (alien-integer-type-signed type
)
33 (values 'signed-byte-32
'signed-stack
)
34 (values 'unsigned-byte-32
'unsigned-stack
))
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 (my-make-wired-tn 'system-area-pointer
46 (define-alien-type-method (long-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
) (+ stack-frame-size
3))
50 (my-make-wired-tn 'long-float
'long-stack stack-frame-size
)))
52 (define-alien-type-method (double-float :arg-tn
) (type state
)
53 (declare (ignore type
))
54 (let ((stack-frame-size (arg-state-stack-frame-size state
)))
55 (setf (arg-state-stack-frame-size state
) (+ stack-frame-size
2))
56 (my-make-wired-tn 'double-float
'double-stack stack-frame-size
)))
58 (define-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 (my-make-wired-tn 'single-float
'single-stack stack-frame-size
)))
64 (defstruct (result-state (:copier nil
))
67 (defun result-reg-offset (slot)
72 (define-alien-type-method (integer :result-tn
) (type state
)
73 (let ((num-results (result-state-num-results state
)))
74 (setf (result-state-num-results state
) (1+ num-results
))
75 (multiple-value-bind (ptype reg-sc
)
76 (if (alien-integer-type-signed type
)
77 (values 'signed-byte-32
'signed-reg
)
78 (values 'unsigned-byte-32
'unsigned-reg
))
79 (my-make-wired-tn ptype reg-sc
(result-reg-offset num-results
)))))
81 (define-alien-type-method (integer :naturalize-gen
) (type alien
)
82 (if (<= (alien-type-bits type
) 16)
83 (if (alien-integer-type-signed type
)
84 `(sign-extend ,alien
,(alien-type-bits type
))
85 `(logand ,alien
,(1- (ash 1 (alien-type-bits type
)))))
88 (define-alien-type-method (system-area-pointer :result-tn
) (type state
)
89 (declare (ignore type
))
90 (let ((num-results (result-state-num-results state
)))
91 (setf (result-state-num-results state
) (1+ num-results
))
92 (my-make-wired-tn 'system-area-pointer
'sap-reg
93 (result-reg-offset num-results
))))
96 (define-alien-type-method (long-float :result-tn
) (type state
)
97 (declare (ignore type
))
98 (let ((num-results (result-state-num-results state
)))
99 (setf (result-state-num-results state
) (1+ num-results
))
100 (my-make-wired-tn 'long-float
'long-reg
(* num-results
2))))
102 (define-alien-type-method (double-float :result-tn
) (type state
)
103 (declare (ignore type
))
104 (let ((num-results (result-state-num-results state
)))
105 (setf (result-state-num-results state
) (1+ num-results
))
106 (my-make-wired-tn 'double-float
'double-reg
(* num-results
2))))
108 (define-alien-type-method (single-float :result-tn
) (type state
)
109 (declare (ignore type
))
110 (let ((num-results (result-state-num-results state
)))
111 (setf (result-state-num-results state
) (1+ num-results
))
112 (my-make-wired-tn 'single-float
'single-reg
(* num-results
2))))
114 (define-alien-type-method (values :result-tn
) (type state
)
115 (let ((values (alien-values-type-values type
)))
116 (when (> (length values
) 2)
117 (error "Too many result values from c-call."))
118 (mapcar (lambda (type)
119 (invoke-alien-type-method :result-tn type state
))
122 (defun make-call-out-tns (type)
123 (let ((arg-state (make-arg-state)))
125 (dolist (arg-type (alien-fun-type-arg-types type
))
126 (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state
)))
127 (values (my-make-wired-tn 'positive-fixnum
'any-reg esp-offset
)
128 (* (arg-state-stack-frame-size arg-state
) n-word-bytes
)
130 (invoke-alien-type-method :result-tn
131 (alien-fun-type-result-type type
)
132 (make-result-state))))))
135 (deftransform %alien-funcall
((function type
&rest args
) * * :node node
)
136 (aver (sb!c
::constant-lvar-p type
))
137 (let* ((type (sb!c
::lvar-value type
))
138 (env (sb!c
::node-lexenv node
))
139 (arg-types (alien-fun-type-arg-types type
))
140 (result-type (alien-fun-type-result-type type
)))
141 (aver (= (length arg-types
) (length args
)))
142 (if (or (some #'(lambda (type)
143 (and (alien-integer-type-p type
)
144 (> (sb!alien
::alien-integer-type-bits type
) 32)))
146 (and (alien-integer-type-p result-type
)
147 (> (sb!alien
::alien-integer-type-bits result-type
) 32)))
148 (collect ((new-args) (lambda-vars) (new-arg-types))
149 (dolist (type arg-types
)
150 (let ((arg (gensym)))
152 (cond ((and (alien-integer-type-p type
)
153 (> (sb!alien
::alien-integer-type-bits type
) 32))
154 (new-args `(logand ,arg
#xffffffff
))
155 (new-args `(ash ,arg -
32))
156 (new-arg-types (parse-alien-type '(unsigned 32) env
))
157 (if (alien-integer-type-signed type
)
158 (new-arg-types (parse-alien-type '(signed 32) env
))
159 (new-arg-types (parse-alien-type '(unsigned 32) env
))))
162 (new-arg-types type
)))))
163 (cond ((and (alien-integer-type-p result-type
)
164 (> (sb!alien
::alien-integer-type-bits result-type
) 32))
165 (let ((new-result-type
166 (let ((sb!alien
::*values-type-okay
* t
))
168 (if (alien-integer-type-signed result-type
)
169 '(values (unsigned 32) (signed 32))
170 '(values (unsigned 32) (unsigned 32)))
172 `(lambda (function type
,@(lambda-vars))
173 (declare (ignore type
))
174 (multiple-value-bind (low high
)
175 (%alien-funcall function
176 ',(make-alien-fun-type
177 :arg-types
(new-arg-types)
178 :result-type new-result-type
)
180 (logior low
(ash high
32))))))
182 `(lambda (function type
,@(lambda-vars))
183 (declare (ignore type
))
184 (%alien-funcall function
185 ',(make-alien-fun-type
186 :arg-types
(new-arg-types)
187 :result-type result-type
)
189 (sb!c
::give-up-ir1-transform
))))
191 ;;; The ABI is vague about how signed sub-word integer return values
192 ;;; are handled, but since gcc versions >=4.3 no longer do sign
193 ;;; extension in the callee, we need to do it in the caller. FIXME:
194 ;;; If the value to be extended is known to already be of the target
195 ;;; type at compile time, we can (and should) elide the extension.
196 (defknown sign-extend
((signed-byte 32) t
) fixnum
197 (foldable flushable movable
))
199 (define-vop (sign-extend)
200 (:translate sign-extend
)
202 ;; Need to wire this to EAX since in x86 some dword registers don't
203 ;; have a matching word or byte register.
204 (:args
(val :scs
(signed-reg) :target eax
))
205 (:temporary
(:sc signed-reg
:offset eax-offset
:from
:eval
:to
:result
) eax
)
206 (:arg-types signed-num
(:constant fixnum
))
208 (:results
(res :scs
(signed-reg)))
209 (:result-types fixnum
)
213 (make-random-tn :kind
:normal
214 :sc
(sc-or-lose (ecase size
217 :offset
(tn-offset val
)))))
220 (defun sign-extend (x size
)
221 (declare (type (signed-byte 32) x
))
223 (8 (sign-extend x size
))
224 (16 (sign-extend x size
))))
227 (defun sign-extend (x size
)
228 (if (logbitp (1- size
) x
)
229 (dpb x
(byte size
0) -
1)
232 (define-vop (foreign-symbol-sap)
233 (:translate foreign-symbol-sap
)
236 (:arg-types
(:constant simple-string
))
237 (:info foreign-symbol
)
238 (:results
(res :scs
(sap-reg)))
239 (:result-types system-area-pointer
)
241 (inst lea res
(make-fixup foreign-symbol
:foreign
))))
244 (define-vop (foreign-symbol-dataref-sap)
245 (:translate foreign-symbol-dataref-sap
)
248 (:arg-types
(:constant simple-string
))
249 (:info foreign-symbol
)
250 (:results
(res :scs
(sap-reg)))
251 (:result-types system-area-pointer
)
253 (inst mov res
(make-fixup foreign-symbol
:foreign-dataref
))))
255 (defun force-x87-to-mem (tn fp-temp
)
256 (aver (location= tn fr0-tn
))
259 (let ((ea (ea-for-sf-stack fp-temp
)))
263 (let ((ea (ea-for-df-stack fp-temp
)))
267 (long-reg ; nothing to do!
270 (define-vop (call-out)
271 (:args
(function :scs
(sap-reg))
273 (:results
(results :more t
))
274 (:temporary
(:sc unsigned-reg
:offset eax-offset
275 :from
:eval
:to
:result
) eax
)
276 (:temporary
(:sc unsigned-reg
:offset ecx-offset
277 :from
:eval
:to
:result
) ecx
)
278 (:temporary
(:sc unsigned-reg
:offset edx-offset
279 :from
:eval
:to
:result
) edx
)
280 (:temporary
(:sc double-stack
) fp-temp
)
281 #!+sb-safepoint
(:temporary
(:sc unsigned-reg
:offset esi-offset
) esi
)
282 #!+sb-safepoint
(:temporary
(:sc unsigned-reg
:offset edi-offset
) edi
)
283 #!-sb-safepoint
(:node-var node
)
286 (:ignore args ecx edx
290 ;; FIXME & OAOOM: This is brittle and error-prone to maintain two
291 ;; instances of the same logic, on in arch-assem.S, and one in
292 ;; c-call.lisp. If you modify this, modify that one too...
294 ;; On safepoints builds, we currently use the out-of-line
295 ;; calling routine irrespectively of SPACE and SPEED policy.
296 ;; An inline version of said changes is left to the
297 ;; sufficiently motivated maintainer.
298 #!-sb-safepoint
(policy node
(> space speed
)))
300 (inst call
(make-fixup "call_into_c" :foreign
))
302 (location= (tn-ref-tn results
) fr0-tn
))
303 (force-x87-to-mem (tn-ref-tn results
) fp-temp
)))
305 ;; Setup the NPX for C; all the FP registers need to be
306 ;; empty; pop them all.
310 ;; Clear out DF: Darwin, Windows, and Solaris at least require
311 ;; this, and it should not hurt others either.
315 ;; To give the debugger a clue. FIXME: not really internal-error?
316 (note-this-location vop
:internal-error
)
318 ;; Restore the NPX for lisp; ensure no regs are empty
323 (location= (tn-ref-tn results
) fr0-tn
))
324 ;; The return result is in fr0.
325 (inst fxch fr7-tn
) ; move the result back to fr0
326 (force-x87-to-mem (tn-ref-tn results
) fp-temp
))
327 (t ; ensure no regs are empty
330 ;;; While SBCL uses the FPU in 53-bit mode, most C libraries assume that
331 ;;; the FPU is in 64-bit mode. So we change the FPU mode to 64-bit with
332 ;;; the SET-FPU-WORD-FOR-C VOP before calling out to C and set it back
333 ;;; to 53-bit mode after coming back using the SET-FPU-WORD-FOR-LISP VOP.
334 (define-vop (set-fpu-word-for-c)
337 (when (policy node
(= sb
!c
::float-accuracy
3))
339 (inst fnstcw
(make-ea :word
:base esp-tn
))
341 (inst or
(make-ea :word
:base esp-tn
) #x300
)
342 (inst fldcw
(make-ea :word
:base esp-tn
))
345 (define-vop (set-fpu-word-for-lisp)
348 (when (policy node
(= sb
!c
::float-accuracy
3))
349 (inst fnstcw
(make-ea :word
:base esp-tn
))
351 (inst and
(make-ea :word
:base esp-tn
) #xfeff
)
352 (inst fldcw
(make-ea :word
:base esp-tn
))
354 (inst add esp-tn
4))))
356 (define-vop (alloc-number-stack-space)
358 (:results
(result :scs
(sap-reg any-reg
)))
359 (:result-types system-area-pointer
)
361 (aver (location= result esp-tn
))
362 (unless (zerop amount
)
363 (let ((delta (logandc2 (+ amount
3) 3)))
364 (inst sub esp-tn delta
)))
365 (align-stack-pointer esp-tn
)
366 (move result esp-tn
)))
368 (define-vop (alloc-alien-stack-space)
370 #!+sb-thread
(:temporary
(:sc unsigned-reg
) temp
)
371 (:results
(result :scs
(sap-reg any-reg
)))
372 (:result-types system-area-pointer
)
375 (aver (not (location= result esp-tn
)))
376 (unless (zerop amount
)
377 (let ((delta (logandc2 (+ amount
3) 3)))
378 (with-tls-ea (EA :base temp
380 :disp
(make-ea-for-symbol-tls-index *alien-stack
*))
381 (inst sub EA delta
:maybe-fs
))))
382 (load-tl-symbol-value result
*alien-stack
*))
385 (aver (not (location= result esp-tn
)))
386 (unless (zerop amount
)
387 (let ((delta (logandc2 (+ amount
3) 3)))
388 (inst sub
(make-ea-for-symbol-value *alien-stack
*)
390 (load-symbol-value result
*alien-stack
*)))
392 (define-vop (dealloc-alien-stack-space)
394 #!+sb-thread
(:temporary
(:sc unsigned-reg
) temp
)
397 (unless (zerop amount
)
398 (let ((delta (logandc2 (+ amount
3) 3)))
399 (with-tls-ea (EA :base temp
401 :disp
(make-ea-for-symbol-tls-index *alien-stack
*))
402 (inst add EA delta
:maybe-fs
)))))
405 (unless (zerop amount
)
406 (let ((delta (logandc2 (+ amount
3) 3)))
407 (inst add
(make-ea-for-symbol-value *alien-stack
*)
410 ;;; not strictly part of the c-call convention, but needed for the
411 ;;; WITH-PINNED-OBJECTS macro used for "locking down" lisp objects so
412 ;;; that GC won't move them while foreign functions go to work.
413 (define-vop (touch-object)
414 (:translate touch-object
)
422 (defun alien-callback-accessor-form (type sp offset
)
423 `(deref (sap-alien (sap+ ,sp
,offset
) (* ,type
))))
426 (defun alien-callback-assembler-wrapper
427 (index return-type arg-types
&optional
(stack-offset 0))
428 "Cons up a piece of code which calls call-callback with INDEX and a
429 pointer to the arguments."
430 (declare (ignore arg-types
))
431 (let* ((segment (make-segment))
436 ([ebp-8
] (make-ea :dword
:base ebp
:disp -
8))
437 ([ebp-4
] (make-ea :dword
:base ebp
:disp -
4)))
439 (inst push ebp
) ; save old frame pointer
440 (inst mov ebp esp
) ; establish new frame
442 (inst sub eax
8) ; place for result
443 (inst push eax
) ; arg2
444 (inst add eax
16) ; arguments
445 (inst push eax
) ; arg1
446 (inst push
(ash index
2)) ; arg0
450 (inst mov eax
(foreign-symbol-address "callback_wrapper_trampoline"))
455 ;; Indirect the access to ENTER-ALIEN-CALLBACK through
456 ;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK*
457 ;; to ensure it'll work even if the GC moves ENTER-ALIEN-CALLBACK.
458 ;; Skip any SB-THREAD TLS magic, since we don't expecte anyone
459 ;; to rebind the variable. -- JES, 2006-01-01
460 (load-symbol-value eax sb
!alien
::*enter-alien-callback
*)
461 (inst push eax
) ; function
462 (inst mov eax
(foreign-symbol-address "funcall3"))
465 ;; now put the result into the right register
467 ((and (alien-integer-type-p return-type
)
468 (eql (alien-type-bits return-type
) 64))
469 (inst mov eax
[ebp-8
])
470 (inst mov edx
[ebp-4
]))
471 ((or (alien-integer-type-p return-type
)
472 (alien-pointer-type-p return-type
)
473 (alien-type-= #.
(parse-alien-type 'system-area-pointer nil
)
475 (inst mov eax
[ebp-8
]))
476 ((alien-single-float-type-p return-type
)
478 ((alien-double-float-type-p return-type
)
480 ((alien-void-type-p return-type
))
482 (error "unrecognized alien type: ~A" return-type
)))
483 (inst mov esp ebp
) ; discard frame
484 (inst pop ebp
) ; restore frame pointer
485 (inst ret stack-offset
))
486 (finalize-segment segment
)
487 ;; Now that the segment is done, convert it to a static
488 ;; vector we can point foreign code to.
489 (let ((buffer (sb!assem
::segment-buffer segment
)))
490 (make-static-vector (length buffer
)
491 :element-type
'(unsigned-byte 8)
492 :initial-contents buffer
))))