4 ;;;; Random pointer comparison VOPs
6 (define-vop (pointer-compare)
7 (:args
(x :scs
(sap-reg))
9 (:arg-types system-area-pointer system-area-pointer
)
10 (:temporary
(:scs
(non-descriptor-reg)) temp
)
14 (:note
"inline comparison")
15 (:variant-vars condition
)
17 (three-way-comparison x y condition
:unsigned not-p target temp
)))
20 (macrolet ((frob (name cond
)
22 (def-primitive-translator ,name
(x y
) `(,',name
,x
,y
))
23 (defknown ,name
(t t
) boolean
(movable foldable flushable
))
24 (define-vop (,name pointer-compare
)
32 ;;;; Type frobbing VOPs
34 (define-vop (lowtag-of)
35 (:translate lowtag-of
)
37 (:args
(object :scs
(any-reg descriptor-reg
)))
38 (:results
(result :scs
(unsigned-reg)))
39 (:result-types positive-fixnum
)
41 (inst and result object lowtag-mask
)))
43 (define-vop (widetag-of)
44 (:translate widetag-of
)
46 (:args
(object :scs
(descriptor-reg)))
47 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
48 (:results
(result :scs
(unsigned-reg)))
49 (:result-types positive-fixnum
)
51 ;; Pick off objects with headers.
52 (inst and ndescr object lowtag-mask
)
53 (inst xor ndescr other-pointer-lowtag
)
54 (inst beq ndescr other-ptr
)
55 (inst xor ndescr
(logxor other-pointer-lowtag fun-pointer-lowtag
))
56 (inst beq ndescr function-ptr
)
59 (inst and result object
3)
60 (inst beq result done
)
62 ;; Pick off structure and list pointers.
63 (inst and result object
1)
64 (inst bne result lowtag-only
)
67 ;; Must be an other immediate.
69 (inst and result object widetag-mask
)
72 (load-type result object
(- fun-pointer-lowtag
))
78 (inst and result object lowtag-mask
)
81 (load-type result object
(- other-pointer-lowtag
))
86 (define-vop (fun-subtype)
87 (:translate fun-subtype
)
89 (:args
(function :scs
(descriptor-reg)))
90 (:results
(result :scs
(unsigned-reg)))
91 (:result-types positive-fixnum
)
93 (load-type result function
(- fun-pointer-lowtag
))
96 (define-vop (set-fun-subtype)
97 (:translate
(setf fun-subtype
))
99 (:args
(type :scs
(unsigned-reg) :target result
)
100 (function :scs
(descriptor-reg)))
101 (:arg-types positive-fixnum
*)
102 (:results
(result :scs
(unsigned-reg)))
103 (:result-types positive-fixnum
)
105 (inst sb type function
(- fun-pointer-lowtag
))
109 (define-vop (get-header-data)
110 (:translate get-header-data
)
112 (:args
(x :scs
(descriptor-reg)))
113 (:results
(res :scs
(unsigned-reg)))
114 (:result-types positive-fixnum
)
116 (loadw res x
0 other-pointer-lowtag
)
117 (inst srl res res n-widetag-bits
)))
119 (define-vop (get-closure-length)
120 (:translate get-closure-length
)
122 (:args
(x :scs
(descriptor-reg)))
123 (:results
(res :scs
(unsigned-reg)))
124 (:result-types positive-fixnum
)
126 (loadw res x
0 fun-pointer-lowtag
)
127 (inst srl res res n-widetag-bits
)))
129 (define-vop (set-header-data)
130 (:translate set-header-data
)
132 (:args
(x :scs
(descriptor-reg) :target res
)
133 (data :scs
(any-reg immediate zero
)))
134 (:arg-types
* positive-fixnum
)
135 (:results
(res :scs
(descriptor-reg)))
136 (:temporary
(:scs
(non-descriptor-reg)) t1 t2
)
138 (loadw t1 x
0 other-pointer-lowtag
)
139 (inst and t1 widetag-mask
)
142 (inst sll t2 data
(- n-widetag-bits
2))
145 (inst or t1
(ash (tn-value data
) n-widetag-bits
)))
147 (storew t1 x
0 other-pointer-lowtag
)
150 (define-vop (make-fixnum)
151 (:args
(ptr :scs
(any-reg descriptor-reg
)))
152 (:results
(res :scs
(any-reg descriptor-reg
)))
155 ;; Some code (the hash table code) depends on this returning a
156 ;; positive number so make sure it does.
158 (inst srl res res
1)))
160 (define-vop (make-other-immediate-type)
161 (:args
(val :scs
(any-reg descriptor-reg
))
162 (type :scs
(any-reg descriptor-reg immediate
)
164 (:results
(res :scs
(any-reg descriptor-reg
)))
165 (:temporary
(:scs
(non-descriptor-reg)) temp
)
169 (inst sll temp val n-widetag-bits
)
170 (inst or res temp
(tn-value type
)))
172 (inst sra temp type
2)
173 (inst sll res val
(- n-widetag-bits
2))
174 (inst or res res temp
)))))
179 (define-vop (dynamic-space-free-pointer)
180 (:results
(int :scs
(sap-reg)))
181 (:result-types system-area-pointer
)
182 (:translate dynamic-space-free-pointer
)
185 (move int alloc-tn
)))
187 (define-vop (binding-stack-pointer-sap)
188 (:results
(int :scs
(sap-reg)))
189 (:result-types system-area-pointer
)
190 (:translate binding-stack-pointer-sap
)
195 (define-vop (control-stack-pointer-sap)
196 (:results
(int :scs
(sap-reg)))
197 (:result-types system-area-pointer
)
198 (:translate control-stack-pointer-sap
)
204 ;;;; Code object frobbing.
206 (define-vop (code-instructions)
207 (:translate code-instructions
)
209 (:args
(code :scs
(descriptor-reg)))
210 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
211 (:results
(sap :scs
(sap-reg)))
212 (:result-types system-area-pointer
)
214 (loadw ndescr code
0 other-pointer-lowtag
)
215 (inst srl ndescr n-widetag-bits
)
216 (inst sll ndescr word-shift
)
217 (inst subu ndescr other-pointer-lowtag
)
218 (inst addu sap code ndescr
)))
220 (define-vop (compute-fun)
221 (:args
(code :scs
(descriptor-reg))
222 (offset :scs
(signed-reg unsigned-reg
)))
223 (:arg-types
* positive-fixnum
)
224 (:results
(func :scs
(descriptor-reg)))
225 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
227 (loadw ndescr code
0 other-pointer-lowtag
)
228 (inst srl ndescr n-widetag-bits
)
229 (inst sll ndescr word-shift
)
230 (inst addu ndescr offset
)
231 (inst addu ndescr
(- fun-pointer-lowtag other-pointer-lowtag
))
232 (inst addu func code ndescr
)))
235 ;;;; Other random VOPs.
238 (defknown sb
!unix
::receive-pending-interrupt
() (values))
239 (define-vop (sb!unix
::receive-pending-interrupt
)
241 (:translate sb
!unix
::receive-pending-interrupt
)
243 (inst break
0 pending-interrupt-trap
)))
248 (inst break
0 halt-trap
)))
251 ;;;; Dynamic vop count collection support
253 (define-vop (count-me)
254 (:args
(count-vector :scs
(descriptor-reg)))
256 (:temporary
(:scs
(non-descriptor-reg)) count
)
259 (- (* (+ index vector-data-offset
) n-word-bytes
) other-pointer-lowtag
)))
260 (inst lw count count-vector offset
)
263 (inst sw count count-vector offset
))))