4 ;;;; Type frobbing VOPs
6 (define-vop (lowtag-of)
9 (:args (object :scs (any-reg descriptor-reg) :target result))
10 (:results (result :scs (unsigned-reg)))
11 (:result-types positive-fixnum)
13 (inst extru object 31 n-lowtag-bits result)))
15 ;FIX this vop got instruction-exploded after mips convert, look at old hppa
16 (define-vop (widetag-of)
17 (:translate widetag-of)
19 (:args (object :scs (descriptor-reg)))
20 (:temporary (:scs (non-descriptor-reg)) temp1 temp2)
21 (:results (result :scs (unsigned-reg)))
22 (:result-types positive-fixnum)
24 (inst li lowtag-mask temp1)
25 (inst li other-pointer-lowtag temp2)
26 (inst and temp1 object temp1)
27 (inst xor temp1 temp2 temp1)
28 (inst comb := temp1 zero-tn OTHER-PTR)
29 (inst li (logxor other-pointer-lowtag fun-pointer-lowtag) temp2)
30 (inst xor temp1 temp2 temp1)
31 (inst comb := temp1 zero-tn FUNCTION-PTR)
32 (inst li 3 temp1) ; pick off fixnums
34 (inst and temp1 object result)
35 (inst comb := result zero-tn DONE)
37 (inst and object temp2 result)
38 (inst comb :<> result zero-tn LOWTAG-ONLY :nullify t)
40 ; must be an other immediate
41 (inst li widetag-mask temp2)
43 (inst and temp2 object result)
46 (load-type result object (- fun-pointer-lowtag))
51 (inst li lowtag-mask temp1)
53 (inst and object temp1 result)
56 (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))
70 (inst nop))) ;FIX-lav, not sure this nop is needed
72 (define-vop (set-fun-subtype)
73 (:translate (setf fun-subtype))
75 (:args (type :scs (unsigned-reg) :target result)
76 (function :scs (descriptor-reg)))
77 (:arg-types positive-fixnum *)
78 (:results (result :scs (unsigned-reg)))
79 (:result-types positive-fixnum)
81 (inst stb type (- fun-pointer-lowtag) function)
84 (define-vop (get-header-data)
85 (:translate get-header-data)
87 (:args (x :scs (descriptor-reg)))
88 (:results (res :scs (unsigned-reg)))
89 (:result-types positive-fixnum)
91 (loadw res x 0 other-pointer-lowtag)
92 (inst srl res n-widetag-bits res)))
94 (define-vop (get-closure-length)
95 (:translate get-closure-length)
97 (:args (x :scs (descriptor-reg)))
98 (:results (res :scs (unsigned-reg)))
99 (:result-types positive-fixnum)
101 (loadw res x 0 fun-pointer-lowtag)
102 (inst srl res n-widetag-bits res)))
103 ;FIX-lav, not sure we need data of type immediate and zero, test without, if so revert to old hppa code
104 (define-vop (set-header-data)
105 (:translate set-header-data)
107 (:args (x :scs (descriptor-reg) :target res)
108 (data :scs (any-reg immediate zero)))
109 (:arg-types * positive-fixnum)
110 (:results (res :scs (descriptor-reg)))
111 (:temporary (:scs (non-descriptor-reg)) t1 t2)
113 (loadw t1 x 0 other-pointer-lowtag)
114 ; replace below 2 inst with: (mask widetag-mask t1 t1)
115 (inst li widetag-mask t2)
119 (inst sll data (- n-widetag-bits 2) t2)
122 (inst li (ash (tn-value data) n-widetag-bits) t2)
126 (storew t1 x 0 other-pointer-lowtag)
129 (define-vop (pointer-hash)
130 (:translate pointer-hash)
131 (:args (ptr :scs (any-reg descriptor-reg)))
132 (:results (res :scs (any-reg descriptor-reg)))
135 (inst zdep ptr 29 29 res)))
137 (define-vop (make-other-immediate-type)
138 (:args (val :scs (any-reg descriptor-reg))
139 (type :scs (any-reg descriptor-reg immediate) :target temp))
140 (:results (res :scs (any-reg descriptor-reg)))
141 (:temporary (:scs (non-descriptor-reg)) temp)
142 (:temporary (:scs (non-descriptor-reg)) t2)
146 (inst sll val n-widetag-bits temp)
147 (inst li (tn-value type) t2)
148 (inst or temp t2 res))
150 (inst sra type 2 temp)
151 (inst sll val (- n-widetag-bits 2) res)
152 (inst or res temp res)))))
156 (define-vop (dynamic-space-free-pointer)
157 (:results (int :scs (sap-reg)))
158 (:result-types system-area-pointer)
159 (:translate dynamic-space-free-pointer)
162 (move alloc-tn int)))
164 (define-vop (binding-stack-pointer-sap)
165 (:results (int :scs (sap-reg)))
166 (:result-types system-area-pointer)
167 (:translate binding-stack-pointer-sap)
172 (define-vop (control-stack-pointer-sap)
173 (:results (int :scs (sap-reg)))
174 (:result-types system-area-pointer)
175 (:translate control-stack-pointer-sap)
181 ;;;; Code object frobbing.
183 (define-vop (code-instructions)
184 (:translate code-instructions)
186 (:args (code :scs (descriptor-reg)))
187 (:temporary (:scs (non-descriptor-reg)) ndescr)
188 (:results (sap :scs (sap-reg)))
189 (:result-types system-area-pointer)
191 (loadw ndescr code 0 other-pointer-lowtag)
192 (inst srl ndescr n-widetag-bits ndescr)
193 (inst sll ndescr word-shift ndescr)
194 (inst addi (- other-pointer-lowtag) ndescr ndescr)
195 (inst add code ndescr sap)))
197 (define-vop (compute-fun)
198 (:args (code :scs (descriptor-reg))
199 (offset :scs (signed-reg unsigned-reg)))
200 (:arg-types * positive-fixnum)
201 (:results (func :scs (descriptor-reg)))
202 (:temporary (:scs (non-descriptor-reg)) ndescr)
204 (loadw ndescr code 0 other-pointer-lowtag)
205 ;FIX-lav: replace below two with DEPW
206 (inst srl ndescr n-widetag-bits ndescr)
207 (inst sll ndescr word-shift ndescr)
208 (inst add ndescr offset ndescr)
209 (inst addi (- fun-pointer-lowtag other-pointer-lowtag) ndescr ndescr)
210 (inst add ndescr code func)))
213 ;;;; Other random VOPs.
216 (defknown sb!unix::receive-pending-interrupt () (values))
217 (define-vop (sb!unix::receive-pending-interrupt)
219 (:translate sb!unix::receive-pending-interrupt)
221 (inst break pending-interrupt-trap)))
226 (inst break halt-trap)))
229 (define-vop (setup-return-from-lisp-stub)
232 (:temporary (:sc any-reg :offset nl0-offset) nl0)
233 (:temporary (:sc any-reg :offset cfunc-offset) cfunc)
234 (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
235 (:temporary (:scs (non-descriptor-reg)) temp)
238 (let ((stub (make-fixup 'return-from-lisp-stub :assembly-routine)))
240 (let ((cur-nfp (current-nfp-tn vop)))
242 (store-stack-tn nfp-save cur-nfp))
243 (inst li (make-fixup "setup_return_from_lisp_stub" :foreign) cfunc)
244 (let ((fixup (make-fixup "call_into_c" :foreign)))
245 (inst ldil fixup temp)
246 (inst ble fixup c-text-space temp))
247 (inst addi 64 nsp-tn nsp-tn)
248 (inst addi -64 nsp-tn nsp-tn)
250 (load-stack-tn cur-nfp nfp-save)))))
252 ;;;; Dynamic vop count collection support
254 (define-vop (count-me)
255 (:args (count-vector :scs (descriptor-reg)))
257 (:temporary (:scs (non-descriptor-reg)) count)
260 (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag)))
261 (inst ldw offset count-vector count)
262 (inst addi 1 count count)
263 (inst stw count offset count-vector))))