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 (lowtag-of)
17 (:translate lowtag-of
)
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 (widetag-of)
28 (:translate widetag-of
)
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-lowtag
)
38 (inst jmp
:e other-ptr
)
39 (inst cmp al-tn fun-pointer-lowtag
)
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
(- fun-pointer-lowtag
))
59 (load-type al-tn object
(- other-pointer-lowtag
))
62 (inst movzx result al-tn
)))
64 (define-vop (fun-subtype)
65 (:translate fun-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
(- fun-pointer-lowtag
))
73 (inst movzx result temp
)))
75 (define-vop (set-fun-subtype)
76 (:translate
(setf fun-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
)
88 (storeb al-tn function
0 fun-pointer-lowtag
)
91 (define-vop (get-header-data)
92 (:translate get-header-data
)
94 (:args
(x :scs
(descriptor-reg)))
95 (:results
(res :scs
(unsigned-reg)))
96 (:result-types positive-fixnum
)
98 (loadw res x
0 other-pointer-lowtag
)
99 (inst shr res n-widetag-bits
)))
101 (define-vop (get-closure-length)
102 (:translate get-closure-length
)
104 (:args
(x :scs
(descriptor-reg)))
105 (:results
(res :scs
(unsigned-reg)))
106 (:result-types positive-fixnum
)
108 (loadw res x
0 fun-pointer-lowtag
)
109 (inst shr res n-widetag-bits
)))
111 (define-vop (set-header-data)
112 (:translate set-header-data
)
114 (:args
(x :scs
(descriptor-reg) :target res
:to
(:result
0))
115 (data :scs
(any-reg) :target eax
))
116 (:arg-types
* positive-fixnum
)
117 (:results
(res :scs
(descriptor-reg)))
118 (:temporary
(:sc unsigned-reg
:offset eax-offset
119 :from
(:argument
1) :to
(:result
0)) eax
)
122 (inst shl eax
(- n-widetag-bits
2))
123 (inst mov al-tn
(make-ea :byte
:base x
:disp
(- other-pointer-lowtag
)))
124 (storew eax x
0 other-pointer-lowtag
)
127 (define-vop (make-fixnum)
128 (:args
(ptr :scs
(any-reg descriptor-reg
) :target res
))
129 (:results
(res :scs
(any-reg descriptor-reg
)))
131 ;; Some code (the hash table code) depends on this returning a
132 ;; positive number so make sure it does.
137 (define-vop (make-other-immediate-type)
138 (:args
(val :scs
(any-reg descriptor-reg
) :target res
)
139 (type :scs
(unsigned-reg immediate
)))
140 (:results
(res :scs
(any-reg descriptor-reg
) :from
(:argument
0)))
143 (inst shl res
(- n-widetag-bits
2))
144 (inst or res
(sc-case type
146 (immediate (tn-value type
))))))
150 (define-vop (dynamic-space-free-pointer)
151 (:results
(int :scs
(sap-reg)))
152 (:result-types system-area-pointer
)
153 (:translate dynamic-space-free-pointer
)
156 (load-symbol-value int
*allocation-pointer
*)))
158 (define-vop (binding-stack-pointer-sap)
159 (:results
(int :scs
(sap-reg)))
160 (:result-types system-area-pointer
)
161 (:translate binding-stack-pointer-sap
)
164 (load-binding-stack-pointer int
)))
166 (defknown (setf binding-stack-pointer-sap
)
167 (system-area-pointer) system-area-pointer
())
169 (define-vop (set-binding-stack-pointer-sap)
170 (:args
(new-value :scs
(sap-reg) :target int
))
171 (:arg-types system-area-pointer
)
172 (:results
(int :scs
(sap-reg)))
173 (:result-types system-area-pointer
)
174 (:translate
(setf binding-stack-pointer-sap
))
177 (store-binding-stack-pointer new-value
)
178 (move int new-value
)))
180 (define-vop (control-stack-pointer-sap)
181 (:results
(int :scs
(sap-reg)))
182 (:result-types system-area-pointer
)
183 (:translate control-stack-pointer-sap
)
188 ;;;; code object frobbing
190 (define-vop (code-instructions)
191 (:translate code-instructions
)
193 (:args
(code :scs
(descriptor-reg) :to
(:result
0)))
194 (:results
(sap :scs
(sap-reg) :from
(:argument
0)))
195 (:result-types system-area-pointer
)
197 (loadw sap code
0 other-pointer-lowtag
)
198 (inst shr sap n-widetag-bits
)
199 (inst lea sap
(make-ea :byte
:base code
:index sap
:scale
4
200 :disp
(- other-pointer-lowtag
)))))
202 (define-vop (compute-fun)
203 (:args
(code :scs
(descriptor-reg) :to
(:result
0))
204 (offset :scs
(signed-reg unsigned-reg
) :to
(:result
0)))
205 (:arg-types
* positive-fixnum
)
206 (:results
(func :scs
(descriptor-reg) :from
(:argument
0)))
208 (loadw func code
0 other-pointer-lowtag
)
209 (inst shr func n-widetag-bits
)
211 (make-ea :byte
:base offset
:index func
:scale
4
212 :disp
(- fun-pointer-lowtag other-pointer-lowtag
)))
213 (inst add func code
)))
215 (define-vop (%simple-fun-self
)
217 (:translate %simple-fun-self
)
218 (:args
(function :scs
(descriptor-reg)))
219 (:results
(result :scs
(descriptor-reg)))
221 (loadw result function simple-fun-self-slot fun-pointer-lowtag
)
223 (make-ea :byte
:base result
224 :disp
(- fun-pointer-lowtag
225 (* simple-fun-code-offset n-word-bytes
))))))
227 ;;; The closure function slot is a pointer to raw code on X86 instead
228 ;;; of a pointer to the code function object itself. This VOP is used
229 ;;; to reference the function object given the closure object.
230 (define-source-transform %closure-fun
(closure)
231 `(%simple-fun-self
,closure
))
233 (define-vop (%set-fun-self
)
235 (:translate
(setf %simple-fun-self
))
236 (:args
(new-self :scs
(descriptor-reg) :target result
:to
:result
)
237 (function :scs
(descriptor-reg) :to
:result
))
238 (:temporary
(:sc any-reg
:from
(:argument
0) :to
:result
) temp
)
239 (:results
(result :scs
(descriptor-reg)))
241 (inst lea temp
(make-ea-for-object-slot new-self simple-fun-code-offset
243 (storew temp function simple-fun-self-slot fun-pointer-lowtag
)
244 (move result new-self
)))
246 ;;;; other miscellaneous VOPs
248 (defknown sb
!unix
::receive-pending-interrupt
() (values))
249 (define-vop (sb!unix
::receive-pending-interrupt
)
251 (:translate sb
!unix
::receive-pending-interrupt
)
253 (inst break pending-interrupt-trap
)))
256 (defknown current-thread-offset-sap
((unsigned-byte 32))
257 system-area-pointer
(flushable))
260 (define-vop (current-thread-offset-sap)
261 (:results
(sap :scs
(sap-reg)))
262 (:result-types system-area-pointer
)
263 (:translate current-thread-offset-sap
)
264 (:args
(n :scs
(unsigned-reg) :target sap
))
265 (:arg-types unsigned-num
)
268 (inst fs-segment-prefix
)
269 (inst mov sap
(make-ea :dword
:disp
0 :index n
:scale
4))))
273 (inst break halt-trap
)))
275 (defknown float-wait
() (values))
276 (define-vop (float-wait)
278 (:translate float-wait
)
280 (:save-p
:compute-only
)
282 (note-next-instruction vop
:internal-error
)
285 ;;;; dynamic vop count collection support
288 (define-vop (count-me)
289 (:args
(count-vector :scs
(descriptor-reg)))
292 (inst inc
(make-ea-for-vector-data count-vector
:offset index
))))