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.
14 ;;;; type frobbing VOPs
16 (define-vop (get-lowtag)
17 (:translate get-lowtag)
19 (:args (object :scs (any-reg descriptor-reg control-stack)
21 (:results (result :scs (unsigned-reg)))
22 (:result-types positive-fixnum)
25 (inst and result lowtag-mask)))
27 (define-vop (get-type)
30 (:args (object :scs (descriptor-reg)))
31 (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
32 (:results (result :scs (unsigned-reg)))
33 (:result-types positive-fixnum)
36 (inst and al-tn lowtag-mask)
37 (inst cmp al-tn other-pointer-type)
38 (inst jmp :e other-ptr)
39 (inst cmp al-tn function-pointer-type)
40 (inst jmp :e function-ptr)
42 ;; pick off structures and list pointers
50 ;; must be an other immediate
55 (load-type al-tn object (- sb!vm:function-pointer-type))
59 (load-type al-tn object (- sb!vm:other-pointer-type))
62 (inst movzx result al-tn)))
64 (define-vop (function-subtype)
65 (:translate function-subtype)
67 (:args (function :scs (descriptor-reg)))
68 (:temporary (:sc byte-reg :from (:eval 0) :to (:eval 1)) temp)
69 (:results (result :scs (unsigned-reg)))
70 (:result-types positive-fixnum)
72 (load-type temp function (- sb!vm:function-pointer-type))
73 (inst movzx result temp)))
75 (define-vop (set-function-subtype)
76 (:translate (setf function-subtype))
78 (:args (type :scs (unsigned-reg) :target eax)
79 (function :scs (descriptor-reg)))
80 (:arg-types positive-fixnum *)
81 (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
82 :to (:result 0) :target result)
84 (:results (result :scs (unsigned-reg)))
85 (:result-types positive-fixnum)
89 (make-ea :byte :base function :disp (- function-pointer-type))
93 (define-vop (get-header-data)
94 (:translate get-header-data)
96 (:args (x :scs (descriptor-reg)))
97 (:results (res :scs (unsigned-reg)))
98 (:result-types positive-fixnum)
100 (loadw res x 0 other-pointer-type)
101 (inst shr res type-bits)))
103 (define-vop (get-closure-length)
104 (:translate get-closure-length)
106 (:args (x :scs (descriptor-reg)))
107 (:results (res :scs (unsigned-reg)))
108 (:result-types positive-fixnum)
110 (loadw res x 0 function-pointer-type)
111 (inst shr res type-bits)))
113 (define-vop (set-header-data)
114 (:translate set-header-data)
116 (:args (x :scs (descriptor-reg) :target res :to (:result 0))
117 (data :scs (any-reg) :target eax))
118 (:arg-types * positive-fixnum)
119 (:results (res :scs (descriptor-reg)))
120 (:temporary (:sc unsigned-reg :offset eax-offset
121 :from (:argument 1) :to (:result 0)) eax)
124 (inst shl eax (- type-bits 2))
125 (inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-type)))
126 (storew eax x 0 other-pointer-type)
129 (define-vop (make-fixnum)
130 (:args (ptr :scs (any-reg descriptor-reg) :target res))
131 (:results (res :scs (any-reg descriptor-reg)))
133 ;; Some code (the hash table code) depends on this returning a
134 ;; positive number so make sure it does.
139 (define-vop (make-other-immediate-type)
140 (:args (val :scs (any-reg descriptor-reg) :target res)
141 (type :scs (unsigned-reg immediate)))
142 (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
145 (inst shl res (- type-bits 2))
146 (inst or res (sc-case type
148 (immediate (tn-value type))))))
152 (define-vop (dynamic-space-free-pointer)
153 (:results (int :scs (sap-reg)))
154 (:result-types system-area-pointer)
155 (:translate dynamic-space-free-pointer)
158 (load-symbol-value int *allocation-pointer*)))
160 (define-vop (binding-stack-pointer-sap)
161 (:results (int :scs (sap-reg)))
162 (:result-types system-area-pointer)
163 (:translate binding-stack-pointer-sap)
166 (load-symbol-value int *binding-stack-pointer*)))
168 (defknown (setf binding-stack-pointer-sap)
169 (system-area-pointer) system-area-pointer ())
171 (define-vop (set-binding-stack-pointer-sap)
172 (:args (new-value :scs (sap-reg) :target int))
173 (:arg-types system-area-pointer)
174 (:results (int :scs (sap-reg)))
175 (:result-types system-area-pointer)
176 (:translate (setf binding-stack-pointer-sap))
179 (store-symbol-value new-value *binding-stack-pointer*)
180 (move int new-value)))
182 (define-vop (control-stack-pointer-sap)
183 (:results (int :scs (sap-reg)))
184 (:result-types system-area-pointer)
185 (:translate control-stack-pointer-sap)
190 ;;;; code object frobbing
192 (define-vop (code-instructions)
193 (:translate code-instructions)
195 (:args (code :scs (descriptor-reg) :to (:result 0)))
196 (:results (sap :scs (sap-reg) :from (:argument 0)))
197 (:result-types system-area-pointer)
199 (loadw sap code 0 other-pointer-type)
200 (inst shr sap type-bits)
201 (inst lea sap (make-ea :byte :base code :index sap :scale 4
202 :disp (- other-pointer-type)))))
204 (define-vop (compute-function)
205 (:args (code :scs (descriptor-reg) :to (:result 0))
206 (offset :scs (signed-reg unsigned-reg) :to (:result 0)))
207 (:arg-types * positive-fixnum)
208 (:results (func :scs (descriptor-reg) :from (:argument 0)))
210 (loadw func code 0 other-pointer-type)
211 (inst shr func type-bits)
213 (make-ea :byte :base offset :index func :scale 4
214 :disp (- function-pointer-type other-pointer-type)))
215 (inst add func code)))
217 (defknown %function-self (function) function (flushable))
219 (define-vop (%function-self)
221 (:translate %function-self)
222 (:args (function :scs (descriptor-reg)))
223 (:results (result :scs (descriptor-reg)))
225 (loadw result function function-self-slot function-pointer-type)
227 (make-ea :byte :base result
228 :disp (- function-pointer-type
229 (* function-code-offset word-bytes))))))
231 ;;; The closure function slot is a pointer to raw code on X86 instead of
232 ;;; a pointer to the code function object itself. This VOP is used
233 ;;; to reference the function object given the closure object.
234 (def-source-transform %closure-function (closure)
235 `(%function-self ,closure))
237 (def-source-transform %funcallable-instance-function (fin)
238 `(%function-self ,fin))
240 (defknown (setf %function-self) (function function) function (unsafe))
242 (define-vop (%set-function-self)
244 (:translate (setf %function-self))
245 (:args (new-self :scs (descriptor-reg) :target result :to :result)
246 (function :scs (descriptor-reg) :to :result))
247 (:temporary (:sc any-reg :from (:argument 0) :to :result) temp)
248 (:results (result :scs (descriptor-reg)))
251 (make-ea :byte :base new-self
252 :disp (- (ash function-code-offset word-shift)
253 function-pointer-type)))
254 (storew temp function function-self-slot function-pointer-type)
255 (move result new-self)))
257 ;; We would have really liked to use a source-transform for this, but
258 ;; they don't work with SETF functions.
259 (defknown ((setf %funcallable-instance-function)) (function function) function
261 (deftransform (setf %funcallable-instance-function) ((value fin))
262 '(setf (%function-self fin) value))
264 ;;;; other miscellaneous VOPs
266 (defknown sb!unix::do-pending-interrupt () (values))
267 (define-vop (sb!unix::do-pending-interrupt)
269 (:translate sb!unix::do-pending-interrupt)
271 (inst break pending-interrupt-trap)))
275 (inst break halt-trap)))
277 (defknown float-wait () (values))
278 (define-vop (float-wait)
280 (:translate float-wait)
282 (:save-p :compute-only)
284 (note-next-instruction vop :internal-error)
287 ;;;; dynamic vop count collection support
290 (define-vop (count-me)
291 (:args (count-vector :scs (descriptor-reg)))
294 (inst inc (make-ea :dword :base count-vector
295 :disp (- (* (+ vector-data-offset index) word-bytes)
296 other-pointer-type)))))