1 ;;;; MIPS 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.
15 ;;;; Type frobbing VOPs
17 (define-vop (widetag-of)
18 (:translate widetag-of
)
20 (:args
(object :scs
(descriptor-reg)))
21 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
22 (:results
(result :scs
(unsigned-reg)))
23 (:result-types positive-fixnum
)
25 ;; Pick off objects with headers.
26 (inst and ndescr object lowtag-mask
)
27 (inst xor ndescr other-pointer-lowtag
)
28 (inst beq ndescr other-ptr
)
29 (inst xor ndescr
(logxor other-pointer-lowtag fun-pointer-lowtag
))
30 (inst beq ndescr function-ptr
)
33 (inst and result object fixnum-tag-mask
)
34 (inst beq result done
)
36 ;; Pick off structure and list pointers.
37 (inst and result object
1)
38 (inst bne result lowtag-only
)
41 ;; Must be an other immediate.
43 (inst and result object widetag-mask
)
46 (load-type result object
(- fun-pointer-lowtag
))
52 (inst and result object lowtag-mask
)
55 (load-type result object
(- other-pointer-lowtag
))
60 (define-vop (%other-pointer-widetag
)
61 (:translate %other-pointer-widetag
)
63 (:args
(object :scs
(descriptor-reg)))
64 (:results
(result :scs
(unsigned-reg)))
65 (:result-types positive-fixnum
)
67 (load-type result object
(- other-pointer-lowtag
))))
69 (define-vop (fun-subtype)
70 (:translate fun-subtype
)
72 (:args
(function :scs
(descriptor-reg)))
73 (:results
(result :scs
(unsigned-reg)))
74 (:result-types positive-fixnum
)
76 (load-type result function
(- fun-pointer-lowtag
))
79 (define-vop (get-header-data)
80 (:translate get-header-data
)
82 (:args
(x :scs
(descriptor-reg)))
83 (:results
(res :scs
(unsigned-reg)))
84 (:result-types positive-fixnum
)
86 (loadw res x
0 other-pointer-lowtag
)
87 (inst srl res res n-widetag-bits
)))
89 (define-vop (get-closure-length)
90 (:translate get-closure-length
)
92 (:args
(x :scs
(descriptor-reg)))
93 (:results
(res :scs
(unsigned-reg)))
94 (:result-types positive-fixnum
)
96 (loadw res x
0 fun-pointer-lowtag
)
97 (inst srl res res n-widetag-bits
)
98 (inst and res res short-header-max-words
)))
100 (define-vop (set-header-data)
101 (:translate set-header-data
)
103 (:args
(x :scs
(descriptor-reg) :target res
)
104 (data :scs
(any-reg immediate zero
)))
105 (:arg-types
* positive-fixnum
)
106 (:results
(res :scs
(descriptor-reg)))
107 (:temporary
(:scs
(non-descriptor-reg)) t1 t2
)
109 (loadw t1 x
0 other-pointer-lowtag
)
110 (inst and t1 widetag-mask
)
113 (inst sll t2 data
(- n-widetag-bits n-fixnum-tag-bits
))
116 (let ((val (ash (tn-value data
) n-widetag-bits
)))
117 (cond ((typep val
'(unsigned-byte 16))
123 (storew t1 x
0 other-pointer-lowtag
)
126 (define-vop (pointer-hash)
127 (:translate pointer-hash
)
128 (:args
(ptr :scs
(any-reg descriptor-reg
)))
129 (:results
(res :scs
(any-reg descriptor-reg
)))
132 ;; FIXME: It would be better if this would mask the lowtag,
133 ;; and shift the result into a positive fixnum like on x86.
135 (inst srl res res
1)))
140 (define-vop (dynamic-space-free-pointer)
141 (:results
(int :scs
(sap-reg)))
142 (:result-types system-area-pointer
)
143 (:translate dynamic-space-free-pointer
)
146 (move int alloc-tn
)))
148 (define-vop (binding-stack-pointer-sap)
149 (:results
(int :scs
(sap-reg)))
150 (:result-types system-area-pointer
)
151 (:translate binding-stack-pointer-sap
)
156 (define-vop (control-stack-pointer-sap)
157 (:results
(int :scs
(sap-reg)))
158 (:result-types system-area-pointer
)
159 (:translate control-stack-pointer-sap
)
165 ;;;; Code object frobbing.
167 (define-vop (code-instructions)
168 (:translate code-instructions
)
170 (:args
(code :scs
(descriptor-reg)))
171 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
172 (:results
(sap :scs
(sap-reg)))
173 (:result-types system-area-pointer
)
175 (loadw ndescr code
0 other-pointer-lowtag
)
176 (inst srl ndescr n-widetag-bits
)
177 (inst sll ndescr word-shift
)
178 (inst subu ndescr other-pointer-lowtag
)
179 (inst addu sap code ndescr
)))
181 (define-vop (compute-fun)
182 (:args
(code :scs
(descriptor-reg))
183 (offset :scs
(signed-reg unsigned-reg
)))
184 (:arg-types
* positive-fixnum
)
185 (:results
(func :scs
(descriptor-reg)))
186 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
188 (loadw ndescr code
0 other-pointer-lowtag
)
189 (inst srl ndescr n-widetag-bits
)
190 (inst sll ndescr word-shift
)
191 (inst addu ndescr offset
)
192 (inst addu ndescr
(- fun-pointer-lowtag other-pointer-lowtag
))
193 (inst addu func code ndescr
)))
196 ;;;; Other random VOPs.
199 (defknown sb
!unix
::receive-pending-interrupt
() (values))
200 (define-vop (sb!unix
::receive-pending-interrupt
)
202 (:translate sb
!unix
::receive-pending-interrupt
)
204 (inst break
0 pending-interrupt-trap
)))
209 (inst break
0 halt-trap
)))
212 ;;;; Dynamic vop count collection support
214 (define-vop (count-me)
215 (:args
(count-vector :scs
(descriptor-reg)))
217 (:temporary
(:scs
(non-descriptor-reg)) count
)
220 (- (* (+ index vector-data-offset
) n-word-bytes
) other-pointer-lowtag
)))
221 (inst lw count count-vector offset
)
224 (inst sw count count-vector offset
))))
226 ;;;; Dummy definition for a spin-loop hint VOP
227 (define-vop (spin-loop-hint)
228 (:translate spin-loop-hint
)