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 (define-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 (define-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 (define-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 (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 (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))))))
70 (define-alien-type-method (integer :result-tn
) (type state
)
71 (declare (ignore state
))
74 (if (alien-integer-type-signed type
)
75 (values 'signed-byte-64
'signed-reg
)
76 (values 'unsigned-byte-64
'unsigned-reg
))
77 (my-make-wired-tn ptype reg-sc lip-offset
)))
79 (define-alien-type-method (system-area-pointer :result-tn
) (type state
)
80 (declare (ignore type state
))
81 (my-make-wired-tn 'system-area-pointer
'sap-reg lip-offset
))
83 (define-alien-type-method (double-float :result-tn
) (type state
)
84 (declare (ignore type state
))
85 (my-make-wired-tn 'double-float
'double-reg lip-offset
))
87 (define-alien-type-method (single-float :result-tn
) (type state
)
88 (declare (ignore type state
))
89 (my-make-wired-tn 'single-float
'single-reg lip-offset
))
91 (define-alien-type-method (values :result-tn
) (type state
)
92 (let ((values (alien-values-type-values type
)))
94 (error "Too many result values from c-call."))
96 (invoke-alien-type-method :result-tn
(car values
) state
))))
98 (!def-vm-support-routine make-call-out-tns
(type)
99 (let ((arg-state (make-arg-state)))
101 (dolist (arg-type (alien-fun-type-arg-types type
))
102 (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state
)))
103 (values (my-make-wired-tn 'positive-fixnum
'any-reg nsp-offset
)
104 (* (max (arg-state-stack-frame-size arg-state
) 4) n-word-bytes
)
106 (invoke-alien-type-method :result-tn
107 (alien-fun-type-result-type type
)
110 (define-vop (foreign-symbol-sap)
111 (:translate foreign-symbol-sap
)
114 (:arg-types
(:constant simple-string
))
115 (:info foreign-symbol
)
116 (:results
(res :scs
(sap-reg)))
117 (:result-types system-area-pointer
)
119 (inst li
(make-fixup foreign-symbol
:foreign
) res
)))
121 (define-vop (call-out)
122 (:args
(function :scs
(sap-reg) :target cfunc
)
124 (:results
(results :more t
))
125 (:ignore args results
)
127 (:temporary
(:sc any-reg
:offset cfunc-offset
128 :from
(:argument
0) :to
(:result
0)) cfunc
)
129 (:temporary
(:sc control-stack
:offset nfp-save-offset
) nfp-save
)
130 (:temporary
(:scs
(non-descriptor-reg)) temp
)
133 (let ((cur-nfp (sb!c
::current-nfp-tn vop
)))
135 (store-stack-tn nfp-save cur-nfp
))
136 (move function cfunc
)
137 (inst li
(make-fixup "call_into_c" :foreign
) temp
)
138 (inst jsr lip-tn temp
(make-fixup "call_into_c" :foreign
))
140 (maybe-load-stack-nfp-tn cur-nfp nfp-save temp
)))))
142 (define-vop (alloc-number-stack-space)
144 (:results
(result :scs
(sap-reg any-reg
)))
145 (:result-types system-area-pointer
)
146 (:temporary
(:scs
(unsigned-reg) :to
(:result
0)) temp
)
148 (unless (zerop amount
)
149 (let ((delta (logandc2 (+ amount
7) 7)))
150 (cond ((< delta
(ash 1 15))
151 (inst lda nsp-tn
(- delta
) nsp-tn
))
154 (inst subq nsp-tn temp nsp-tn
)))))
155 (move nsp-tn result
)))
157 (define-vop (dealloc-number-stack-space)
160 (:temporary
(:scs
(unsigned-reg) :to
(:result
0)) temp
)
162 (unless (zerop amount
)
163 (let ((delta (logandc2 (+ amount
7) 7)))
164 (cond ((< delta
(ash 1 15))
165 (inst lda nsp-tn delta nsp-tn
))
168 (inst addq nsp-tn temp nsp-tn
)))))))