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
)
23 (:constructor make-arg-info
(offset prim-type reg-sc stack-sc
)))
29 (define-alien-type-method (integer :arg-tn
) (type state
)
30 (let ((args (arg-state-args state
)))
31 (setf (arg-state-args state
) (1+ args
))
32 (if (alien-integer-type-signed type
)
33 (make-arg-info args
'signed-byte-32
'signed-reg
'signed-stack
)
34 (make-arg-info args
'unsigned-byte-32
'unsigned-reg
'unsigned-stack
))))
36 (define-alien-type-method (system-area-pointer :arg-tn
) (type state
)
37 (declare (ignore type
))
38 (let ((args (arg-state-args state
)))
39 (setf (arg-state-args state
) (1+ args
))
40 (make-arg-info args
'system-area-pointer
'sap-reg
'sap-stack
)))
42 (define-alien-type-method (single-float :arg-tn
) (type state
)
43 (declare (ignore type
))
44 (let ((args (arg-state-args state
)))
45 (setf (arg-state-args state
) (1+ args
))
46 (make-arg-info args
'single-float
'single-reg
'single-stack
)))
48 (define-alien-type-method (double-float :arg-tn
) (type state
)
49 (declare (ignore type
))
50 (let ((args (logior (1+ (arg-state-args state
)) 1)))
51 (setf (arg-state-args state
) (1+ args
))
52 (make-arg-info args
'double-float
'double-reg
'double-stack
)))
54 (define-alien-type-method (integer :result-tn
) (type)
55 (if (alien-integer-type-signed type
)
56 (my-make-wired-tn 'signed-byte-32
'signed-reg nl4-offset
)
57 (my-make-wired-tn 'unsigned-byte-32
'unsigned-reg nl4-offset
)))
59 (define-alien-type-method (system-area-pointer :result-tn
) (type)
60 (declare (ignore type
))
61 (my-make-wired-tn 'system-area-pointer
'sap-reg nl4-offset
))
63 (define-alien-type-method (single-float :result-tn
) (type)
64 (declare (ignore type
))
65 (my-make-wired-tn 'single-float
'single-reg
4))
67 (define-alien-type-method (double-float :result-tn
) (type)
68 (declare (ignore type
))
69 (my-make-wired-tn 'double-float
'double-reg
4))
71 (define-alien-type-method (values :result-tn
) (type)
72 (let ((values (alien-values-type-values type
)))
74 (aver (null (cdr values
)))
75 (invoke-alien-type-method :result-tn
(car values
)))))
77 (defun make-arg-tns (type)
78 (let* ((state (make-arg-state))
79 (args (mapcar #'(lambda (arg-type)
80 (invoke-alien-type-method :arg-tn arg-type state
))
81 (alien-fun-type-arg-types type
)))
82 ;; We need 8 words of cruft, and we need to round up to a multiple
84 (frame-size (logandc2 (+ (arg-state-args state
) 8 15) 15)))
86 (mapcar #'(lambda (arg)
87 (declare (type arg-info arg
))
88 (let ((offset (arg-info-offset arg
))
89 (prim-type (arg-info-prim-type arg
)))
91 (my-make-wired-tn prim-type
(arg-info-stack-sc arg
)
92 (- frame-size offset
8 1)))
93 ((or (eq prim-type
'single-float
)
94 (eq prim-type
'double-float
))
95 (my-make-wired-tn prim-type
(arg-info-reg-sc arg
)
98 (my-make-wired-tn prim-type
(arg-info-reg-sc arg
)
99 (- nl0-offset offset
))))))
101 (* frame-size n-word-bytes
))))
103 (!def-vm-support-routine make-call-out-tns
(type)
104 (declare (type alien-fun-type type
))
108 (values (make-normal-tn *fixnum-primitive-type
*)
111 (invoke-alien-type-method
113 (alien-fun-type-result-type type
)))))
115 (define-vop (foreign-symbol-sap)
116 (:translate foreign-symbol-sap
)
119 (:arg-types
(:constant simple-string
))
120 (:info foreign-symbol
)
121 (:results
(res :scs
(sap-reg)))
122 (:result-types system-area-pointer
)
124 (inst li
(make-fixup foreign-symbol
:foreign
) res
)))
126 (define-vop (call-out)
127 (:args
(function :scs
(sap-reg) :target cfunc
)
129 (:results
(results :more t
))
130 (:ignore args results
)
132 (:temporary
(:sc any-reg
:offset cfunc-offset
133 :from
(:argument
0) :to
(:result
0)) cfunc
)
134 (:temporary
(:scs
(any-reg) :to
(:result
0)) temp
)
135 (:temporary
(:sc control-stack
:offset nfp-save-offset
) nfp-save
)
138 (let ((cur-nfp (current-nfp-tn vop
)))
140 (store-stack-tn nfp-save cur-nfp
))
141 (move function cfunc
)
142 (let ((fixup (make-fixup "call_into_c" :foreign
)))
143 (inst ldil fixup temp
)
144 (inst ble fixup c-text-space temp
:nullify t
))
147 (load-stack-tn cur-nfp nfp-save
)))))
149 (define-vop (alloc-number-stack-space)
151 (:results
(result :scs
(sap-reg any-reg
)))
152 (:result-types system-area-pointer
)
153 (:temporary
(:scs
(unsigned-reg) :to
(:result
0)) temp
)
156 (unless (zerop amount
)
157 (let ((delta (logandc2 (+ amount
63) 63)))
158 (cond ((< delta
(ash 1 10))
159 (inst addi delta nsp-tn nsp-tn
))
162 (inst add temp nsp-tn nsp-tn
)))))))
164 (define-vop (dealloc-number-stack-space)
167 (:temporary
(:scs
(unsigned-reg) :to
(:result
0)) temp
)
169 (unless (zerop amount
)
170 (let ((delta (- (logandc2 (+ amount
63) 63))))
171 (cond ((<= (- (ash 1 10)) delta
)
172 (inst addi delta nsp-tn nsp-tn
))
175 (inst add temp nsp-tn nsp-tn
)))))))