1 ;;;; Alpha 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 object lowtag-mask result
)))
25 (define-vop (widetag-of)
26 (:translate widetag-of
)
28 (:args
(object :scs
(descriptor-reg)))
29 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
30 (:results
(result :scs
(unsigned-reg)))
31 (:result-types positive-fixnum
)
33 ;; Pick off objects with headers.
34 (inst and object lowtag-mask result
)
35 (inst cmpeq result other-pointer-lowtag ndescr
)
36 (inst bne ndescr other-ptr
)
37 (inst cmpeq result fun-pointer-lowtag ndescr
)
38 (inst bne ndescr function-ptr
)
40 ;; Pick off structure and list pointers.
41 (inst blbs object done
)
44 (inst and object fixnum-tag-mask result
)
45 (inst beq result done
)
47 ;; Must be an other immediate.
48 (inst and object widetag-mask result
)
49 (inst br zero-tn done
)
52 (load-type result object
(- fun-pointer-lowtag
))
53 (inst br zero-tn done
)
56 (load-type result object
(- other-pointer-lowtag
))
60 (define-vop (fun-subtype)
61 (:translate fun-subtype
)
63 (:args
(function :scs
(descriptor-reg)))
64 (:results
(result :scs
(unsigned-reg)))
65 (:result-types positive-fixnum
)
67 (load-type result function
(- fun-pointer-lowtag
))))
69 (define-vop (set-fun-subtype)
70 (:translate
(setf fun-subtype
))
72 (:args
(type :scs
(unsigned-reg) :target result
)
73 (function :scs
(descriptor-reg)))
74 (:arg-types positive-fixnum
*)
75 (:temporary
(:scs
(non-descriptor-reg)) temp
)
76 (:results
(result :scs
(unsigned-reg)))
77 (:result-types positive-fixnum
)
79 (inst ldl temp
(- fun-pointer-lowtag
) function
)
80 (inst and temp
#xff temp
)
81 (inst bis type temp temp
)
82 (inst stl temp
(- fun-pointer-lowtag
) function
)
86 (define-vop (get-header-data)
87 (:translate get-header-data
)
89 (:args
(x :scs
(descriptor-reg)))
90 (:results
(res :scs
(unsigned-reg)))
91 (:result-types positive-fixnum
)
93 (loadw res x
0 other-pointer-lowtag
)
94 (inst srl res n-widetag-bits res
)))
96 (define-vop (get-closure-length)
97 (:translate get-closure-length
)
99 (:args
(x :scs
(descriptor-reg)))
100 (:results
(res :scs
(unsigned-reg)))
101 (:result-types positive-fixnum
)
103 (loadw res x
0 fun-pointer-lowtag
)
104 (inst srl res n-widetag-bits res
)))
106 (define-vop (set-header-data)
107 (:translate set-header-data
)
109 (:args
(x :scs
(descriptor-reg) :target res
)
110 (data :scs
(any-reg immediate zero
)))
111 (:arg-types
* positive-fixnum
)
112 (:results
(res :scs
(descriptor-reg)))
113 (:temporary
(:scs
(non-descriptor-reg)) t1 t2
)
115 (loadw t1 x
0 other-pointer-lowtag
)
116 (inst and t1 widetag-mask t1
)
119 (inst sll data
(- n-widetag-bits
2) t2
)
122 (let ((c (ash (tn-value data
) n-widetag-bits
)))
123 (cond ((<= 0 c
(1- (ash 1 8)))
127 (inst bis t1 t2 t1
)))))
129 (storew t1 x
0 other-pointer-lowtag
)
132 (define-vop (pointer-hash)
133 (:translate pointer-hash
)
134 (:args
(ptr :scs
(any-reg descriptor-reg
)))
135 (:results
(res :scs
(any-reg descriptor-reg
)))
138 ;; FIXME: It would be better if this would mask the lowtag,
139 ;; and shift the result into a positive fixnum like on x86.
140 (inst sll ptr
35 res
)
141 (inst srl res
33 res
)))
143 (define-vop (make-other-immediate-type)
144 (:args
(val :scs
(any-reg descriptor-reg
))
145 (type :scs
(any-reg descriptor-reg immediate
)
147 (:results
(res :scs
(any-reg descriptor-reg
)))
148 (:temporary
(:scs
(non-descriptor-reg)) temp
)
152 (inst sll val n-widetag-bits temp
)
153 (inst bis temp
(tn-value type
) res
))
155 (inst sra type n-fixnum-tag-bits temp
)
156 (inst sll val
(- n-widetag-bits n-fixnum-tag-bits
) res
)
157 (inst bis res temp res
)))))
162 (define-vop (dynamic-space-free-pointer)
163 (:results
(int :scs
(sap-reg)))
164 (:result-types system-area-pointer
)
165 (:translate dynamic-space-free-pointer
)
168 (move alloc-tn int
)))
170 (define-vop (binding-stack-pointer-sap)
171 (:results
(int :scs
(sap-reg)))
172 (:result-types system-area-pointer
)
173 (:translate binding-stack-pointer-sap
)
178 (define-vop (control-stack-pointer-sap)
179 (:results
(int :scs
(sap-reg)))
180 (:result-types system-area-pointer
)
181 (:translate control-stack-pointer-sap
)
187 ;;;; code object frobbing
189 (define-vop (code-instructions)
190 (:translate code-instructions
)
192 (:args
(code :scs
(descriptor-reg)))
193 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
194 (:results
(sap :scs
(sap-reg)))
195 (:result-types system-area-pointer
)
197 (loadw ndescr code
0 other-pointer-lowtag
)
198 (inst srl ndescr n-widetag-bits ndescr
)
199 (inst sll ndescr word-shift ndescr
)
200 (inst subq ndescr other-pointer-lowtag ndescr
)
201 (inst addq code ndescr sap
)))
203 (define-vop (compute-fun)
204 (:args
(code :scs
(descriptor-reg))
205 (offset :scs
(signed-reg unsigned-reg
)))
206 (:arg-types
* positive-fixnum
)
207 (:results
(func :scs
(descriptor-reg)))
208 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
210 (loadw ndescr code
0 other-pointer-lowtag
)
211 (inst srl ndescr n-widetag-bits ndescr
)
212 (inst sll ndescr word-shift ndescr
)
213 (inst addq ndescr offset ndescr
)
214 (inst subq ndescr
(- other-pointer-lowtag fun-pointer-lowtag
) ndescr
)
215 (inst addq code ndescr func
)))
217 ;;;; other random VOPs.
219 (defknown sb
!unix
::receive-pending-interrupt
() (values))
220 (define-vop (sb!unix
::receive-pending-interrupt
)
222 (:translate sb
!unix
::receive-pending-interrupt
)
224 (inst gentrap pending-interrupt-trap
)))
229 (inst gentrap halt-trap
)))
231 (define-vop (istream-memory-barrier)
235 ;;;; dynamic vop count collection support
237 (define-vop (count-me)
238 (:args
(count-vector :scs
(descriptor-reg)))
240 (:temporary
(:scs
(non-descriptor-reg)) count
)
243 (- (* (+ index vector-data-offset
) n-word-bytes
)
244 other-pointer-lowtag
)))
245 (inst ldl count offset count-vector
)
246 (inst addq count
1 count
)
247 (inst stl count offset count-vector
))))