1 ;;;; x86 VM definitions of various system hacking operations
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.
17 ;;;; type frobbing VOPs
19 (define-vop (get-lowtag)
20 (:translate get-lowtag)
22 (:args (object :scs (any-reg descriptor-reg control-stack)
24 (:results (result :scs (unsigned-reg)))
25 (:result-types positive-fixnum)
28 (inst and result lowtag-mask)))
30 (define-vop (get-type)
33 (:args (object :scs (descriptor-reg)))
34 (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
35 (:results (result :scs (unsigned-reg)))
36 (:result-types positive-fixnum)
39 (inst and al-tn lowtag-mask)
40 (inst cmp al-tn other-pointer-type)
41 (inst jmp :e other-ptr)
42 (inst cmp al-tn function-pointer-type)
43 (inst jmp :e function-ptr)
45 ;; pick off structures and list pointers
53 ;; must be an other immediate
58 (load-type al-tn object (- sb!vm:function-pointer-type))
62 (load-type al-tn object (- sb!vm:other-pointer-type))
65 (inst movzx result al-tn)))
67 (define-vop (function-subtype)
68 (:translate function-subtype)
70 (:args (function :scs (descriptor-reg)))
71 (:temporary (:sc byte-reg :from (:eval 0) :to (:eval 1)) temp)
72 (:results (result :scs (unsigned-reg)))
73 (:result-types positive-fixnum)
75 (load-type temp function (- sb!vm:function-pointer-type))
76 (inst movzx result temp)))
78 (define-vop (set-function-subtype)
79 (:translate (setf function-subtype))
81 (:args (type :scs (unsigned-reg) :target eax)
82 (function :scs (descriptor-reg)))
83 (:arg-types positive-fixnum *)
84 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
85 :to (:result 0) :target result)
87 (:results (result :scs (unsigned-reg)))
88 (:result-types positive-fixnum)
92 (make-ea :byte :base function :disp (- function-pointer-type))
96 (define-vop (get-header-data)
97 (:translate get-header-data)
99 (:args (x :scs (descriptor-reg)))
100 (:results (res :scs (unsigned-reg)))
101 (:result-types positive-fixnum)
103 (loadw res x 0 other-pointer-type)
104 (inst shr res type-bits)))
106 (define-vop (get-closure-length)
107 (:translate get-closure-length)
109 (:args (x :scs (descriptor-reg)))
110 (:results (res :scs (unsigned-reg)))
111 (:result-types positive-fixnum)
113 (loadw res x 0 function-pointer-type)
114 (inst shr res type-bits)))
116 (define-vop (set-header-data)
117 (:translate set-header-data)
119 (:args (x :scs (descriptor-reg) :target res :to (:result 0))
120 (data :scs (any-reg) :target eax))
121 (:arg-types * positive-fixnum)
122 (:results (res :scs (descriptor-reg)))
123 (:temporary (:sc unsigned-reg :offset eax-offset
124 :from (:argument 1) :to (:result 0)) eax)
127 (inst shl eax (- type-bits 2))
128 (inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-type)))
129 (storew eax x 0 other-pointer-type)
132 (define-vop (make-fixnum)
133 (:args (ptr :scs (any-reg descriptor-reg) :target res))
134 (:results (res :scs (any-reg descriptor-reg)))
136 ;; Some code (the hash table code) depends on this returning a
137 ;; positive number so make sure it does.
142 (define-vop (make-other-immediate-type)
143 (:args (val :scs (any-reg descriptor-reg) :target res)
144 (type :scs (unsigned-reg immediate)))
145 (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
148 (inst shl res (- type-bits 2))
149 (inst or res (sc-case type
151 (immediate (tn-value type))))))
155 (define-vop (dynamic-space-free-pointer)
156 (:results (int :scs (sap-reg)))
157 (:result-types system-area-pointer)
158 (:translate dynamic-space-free-pointer)
161 (load-symbol-value int *allocation-pointer*)))
163 (define-vop (binding-stack-pointer-sap)
164 (:results (int :scs (sap-reg)))
165 (:result-types system-area-pointer)
166 (:translate binding-stack-pointer-sap)
169 (load-symbol-value int *binding-stack-pointer*)))
171 (defknown (setf binding-stack-pointer-sap)
172 (system-area-pointer) system-area-pointer ())
174 (define-vop (set-binding-stack-pointer-sap)
175 (:args (new-value :scs (sap-reg) :target int))
176 (:arg-types system-area-pointer)
177 (:results (int :scs (sap-reg)))
178 (:result-types system-area-pointer)
179 (:translate (setf binding-stack-pointer-sap))
182 (store-symbol-value new-value *binding-stack-pointer*)
183 (move int new-value)))
185 (define-vop (control-stack-pointer-sap)
186 (:results (int :scs (sap-reg)))
187 (:result-types system-area-pointer)
188 (:translate control-stack-pointer-sap)
193 ;;;; code object frobbing
195 (define-vop (code-instructions)
196 (:translate code-instructions)
198 (:args (code :scs (descriptor-reg) :to (:result 0)))
199 (:results (sap :scs (sap-reg) :from (:argument 0)))
200 (:result-types system-area-pointer)
202 (loadw sap code 0 other-pointer-type)
203 (inst shr sap type-bits)
204 (inst lea sap (make-ea :byte :base code :index sap :scale 4
205 :disp (- other-pointer-type)))))
207 (define-vop (compute-function)
208 (:args (code :scs (descriptor-reg) :to (:result 0))
209 (offset :scs (signed-reg unsigned-reg) :to (:result 0)))
210 (:arg-types * positive-fixnum)
211 (:results (func :scs (descriptor-reg) :from (:argument 0)))
213 (loadw func code 0 other-pointer-type)
214 (inst shr func type-bits)
216 (make-ea :byte :base offset :index func :scale 4
217 :disp (- function-pointer-type other-pointer-type)))
218 (inst add func code)))
220 (defknown %function-self (function) function (flushable))
222 (define-vop (%function-self)
224 (:translate %function-self)
225 (:args (function :scs (descriptor-reg)))
226 (:results (result :scs (descriptor-reg)))
228 (loadw result function function-self-slot function-pointer-type)
230 (make-ea :byte :base result
231 :disp (- function-pointer-type
232 (* function-code-offset word-bytes))))))
234 ;;; The closure function slot is a pointer to raw code on X86 instead of
235 ;;; a pointer to the code function object itself. This VOP is used
236 ;;; to reference the function object given the closure object.
237 (def-source-transform %closure-function (closure)
238 `(%function-self ,closure))
240 (def-source-transform %funcallable-instance-function (fin)
241 `(%function-self ,fin))
243 (defknown (setf %function-self) (function function) function (unsafe))
245 (define-vop (%set-function-self)
247 (:translate (setf %function-self))
248 (:args (new-self :scs (descriptor-reg) :target result :to :result)
249 (function :scs (descriptor-reg) :to :result))
250 (:temporary (:sc any-reg :from (:argument 0) :to :result) temp)
251 (:results (result :scs (descriptor-reg)))
254 (make-ea :byte :base new-self
255 :disp (- (ash function-code-offset word-shift)
256 function-pointer-type)))
257 (storew temp function function-self-slot function-pointer-type)
258 (move result new-self)))
260 ;; We would have really liked to use a source-transform for this, but
261 ;; they don't work with SETF functions.
262 (defknown ((setf %funcallable-instance-function)) (function function) function
264 (deftransform (setf %funcallable-instance-function) ((value fin))
265 '(setf (%function-self fin) value))
267 ;;;; other miscellaneous VOPs
269 (defknown sb!unix::do-pending-interrupt () (values))
270 (define-vop (sb!unix::do-pending-interrupt)
272 (:translate sb!unix::do-pending-interrupt)
274 (inst break pending-interrupt-trap)))
278 (inst break halt-trap)))
280 (defknown float-wait () (values))
281 (define-vop (float-wait)
283 (:translate float-wait)
285 (:save-p :compute-only)
287 (note-next-instruction vop :internal-error)
290 ;;;; dynamic vop count collection support
293 (define-vop (count-me)
294 (:args (count-vector :scs (descriptor-reg)))
297 (inst inc (make-ea :dword :base count-vector
298 :disp (- (* (+ vector-data-offset index) word-bytes)
299 other-pointer-type)))))