1 ;;;; Sparc 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
)))
20 (:results
(result :scs
(unsigned-reg)))
21 (:result-types positive-fixnum
)
23 (inst and result object lowtag-mask
)))
25 (define-vop (widetag-of)
26 (:translate widetag-of
)
28 (:args
(object :scs
(descriptor-reg) :to
(:eval
1)))
29 (:results
(result :scs
(unsigned-reg) :from
(:eval
0)))
30 (:result-types positive-fixnum
)
33 (inst andcc result object lowtag-mask
)
34 ;; Check for various pointer types.
35 (inst cmp result list-pointer-lowtag
)
37 (inst cmp result other-pointer-lowtag
)
38 (inst b
:eq other-pointer
)
39 (inst cmp result fun-pointer-lowtag
)
40 (inst b
:eq function-pointer
)
41 (inst cmp result instance-pointer-lowtag
)
43 ;; Okay, it is an immediate. If fixnum, we want zero. Otherwise,
44 ;; we want the low 8 bits.
45 (inst andcc zero-tn object
#b11
)
48 ;; It wasn't a fixnum, so get the low 8 bits.
50 (inst and result object widetag-mask
)
54 (load-type result object
(- fun-pointer-lowtag
))
57 (load-type result object
(- other-pointer-lowtag
))
62 (define-vop (fun-subtype)
63 (:translate fun-subtype
)
65 (:args
(function :scs
(descriptor-reg)))
66 (:results
(result :scs
(unsigned-reg)))
67 (:result-types positive-fixnum
)
69 (load-type result function
(- fun-pointer-lowtag
))))
71 ;;; Is this VOP dead? I can't see anywhere that it is used... -- CSR,
73 (define-vop (set-fun-subtype)
74 (:translate
(setf fun-subtype
))
76 (:args
(type :scs
(unsigned-reg) :target result
)
77 (function :scs
(descriptor-reg)))
78 (:arg-types positive-fixnum
*)
79 (:results
(result :scs
(unsigned-reg)))
80 (:result-types positive-fixnum
)
82 ;; FIXME: I don't understand what this hardcoded 3 is doing
83 ;; here. -- CSR, 2002-02-08
84 (inst stb type function
(- 3 fun-pointer-lowtag
))
87 (define-vop (get-header-data)
88 (:translate get-header-data
)
90 (:args
(x :scs
(descriptor-reg)))
91 (:results
(res :scs
(unsigned-reg)))
92 (:result-types positive-fixnum
)
94 (loadw res x
0 other-pointer-lowtag
)
95 (inst srl res res n-widetag-bits
)))
97 (define-vop (get-closure-length)
98 (:translate get-closure-length
)
100 (:args
(x :scs
(descriptor-reg)))
101 (:results
(res :scs
(unsigned-reg)))
102 (:result-types positive-fixnum
)
104 (loadw res x
0 fun-pointer-lowtag
)
105 (inst srl res res n-widetag-bits
)))
107 (define-vop (set-header-data)
108 (:translate set-header-data
)
110 (:args
(x :scs
(descriptor-reg) :target res
)
111 (data :scs
(any-reg immediate zero
)))
112 (:arg-types
* positive-fixnum
)
113 (:results
(res :scs
(descriptor-reg)))
114 (:temporary
(:scs
(non-descriptor-reg)) t1 t2
)
116 (loadw t1 x
0 other-pointer-lowtag
)
117 (inst and t1 widetag-mask
)
120 (inst sll t2 data
(- n-widetag-bits
2))
123 (inst or t1
(ash (tn-value data
) n-widetag-bits
)))
125 (storew t1 x
0 other-pointer-lowtag
)
129 (define-vop (make-fixnum)
130 (:args
(ptr :scs
(any-reg descriptor-reg
)))
131 (:results
(res :scs
(any-reg descriptor-reg
)))
133 ;; FIXME: CMUCL comment:
134 ;; Some code (the hash table code) depends on this returning a
135 ;; positive number so make sure it does.
137 (inst srl res res
1)))
139 (define-vop (make-other-immediate-type)
140 (:args
(val :scs
(any-reg descriptor-reg
))
141 (type :scs
(any-reg descriptor-reg immediate
)
143 (:results
(res :scs
(any-reg descriptor-reg
)))
144 (:temporary
(:scs
(non-descriptor-reg)) temp
)
148 (inst sll temp val n-widetag-bits
)
149 (inst or res temp
(tn-value type
)))
151 (inst sra temp type
2)
152 (inst sll res val
(- n-widetag-bits
2))
153 (inst or res res temp
)))))
158 (define-vop (dynamic-space-free-pointer)
159 (:results
(int :scs
(sap-reg)))
160 (:result-types system-area-pointer
)
161 (:translate dynamic-space-free-pointer
)
164 (move int alloc-tn
)))
166 (define-vop (binding-stack-pointer-sap)
167 (:results
(int :scs
(sap-reg)))
168 (:result-types system-area-pointer
)
169 (:translate binding-stack-pointer-sap
)
174 (define-vop (control-stack-pointer-sap)
175 (:results
(int :scs
(sap-reg)))
176 (:result-types system-area-pointer
)
177 (:translate control-stack-pointer-sap
)
183 ;;;; code object frobbing.
185 (define-vop (code-instructions)
186 (:translate code-instructions
)
188 (:args
(code :scs
(descriptor-reg)))
189 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
190 (:results
(sap :scs
(sap-reg)))
191 (:result-types system-area-pointer
)
193 (loadw ndescr code
0 other-pointer-lowtag
)
194 (inst srl ndescr n-widetag-bits
)
195 (inst sll ndescr word-shift
)
196 (inst sub ndescr other-pointer-lowtag
)
197 (inst add sap code ndescr
)))
199 (define-vop (compute-fun)
200 (:args
(code :scs
(descriptor-reg))
201 (offset :scs
(signed-reg unsigned-reg
)))
202 (:arg-types
* positive-fixnum
)
203 (:results
(func :scs
(descriptor-reg)))
204 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
206 (loadw ndescr code
0 other-pointer-lowtag
)
207 (inst srl ndescr n-widetag-bits
)
208 (inst sll ndescr word-shift
)
209 (inst add ndescr offset
)
210 (inst add ndescr
(- fun-pointer-lowtag other-pointer-lowtag
))
211 (inst add func code ndescr
)))
215 ;;;; other random VOPs.
218 (defknown sb
!unix
::receive-pending-interrupt
() (values))
219 (define-vop (sb!unix
::receive-pending-interrupt
)
221 (:translate sb
!unix
::receive-pending-interrupt
)
223 (inst unimp pending-interrupt-trap
)))
226 (error "write a VOP for CURRENT-THREAD-OFFSET-SAP")
230 (inst unimp halt-trap
)))
234 ;;;; dynamic VOP count collection support
236 (define-vop (count-me)
237 (:args
(count-vector :scs
(descriptor-reg)))
239 (:temporary
(:scs
(non-descriptor-reg)) count
)
242 (- (* (+ index vector-data-offset
) n-word-bytes
)
243 other-pointer-lowtag
)))
244 (aver (typep offset
'(signed-byte 13)))
245 (inst ld count count-vector offset
)
247 (inst st count count-vector offset
))))