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))
47 (inst b done :nullify t)
50 (inst li lowtag-mask temp1)
52 (inst and object temp1 result)
55 (load-type result object (- other-pointer-lowtag))
59 (define-vop (fun-subtype)
60 (:translate fun-subtype)
62 (:args (function :scs (descriptor-reg)))
63 (:results (result :scs (unsigned-reg)))
64 (:result-types positive-fixnum)
66 (load-type result function (- fun-pointer-lowtag))))
68 (define-vop (set-fun-subtype)
69 (:translate (setf fun-subtype))
71 (:args (type :scs (unsigned-reg) :target result)
72 (function :scs (descriptor-reg)))
73 (:arg-types positive-fixnum *)
74 (:results (result :scs (unsigned-reg)))
75 (:result-types positive-fixnum)
77 (inst stb type (- fun-pointer-lowtag) function)
80 (define-vop (get-header-data)
81 (:translate get-header-data)
83 (:args (x :scs (descriptor-reg)))
84 (:results (res :scs (unsigned-reg)))
85 (:result-types positive-fixnum)
87 (loadw res x 0 other-pointer-lowtag)
88 (inst srl res n-widetag-bits res)))
90 (define-vop (get-closure-length)
91 (:translate get-closure-length)
93 (:args (x :scs (descriptor-reg)))
94 (:results (res :scs (unsigned-reg)))
95 (:result-types positive-fixnum)
97 (loadw res x 0 fun-pointer-lowtag)
98 (inst srl res n-widetag-bits res)))
99 ;;; FIXME-lav, not sure we need data of type immediate and zero, test without,
100 ;;; if so revert to old hppa code
101 (define-vop (set-header-data)
102 (:translate set-header-data)
104 (:args (x :scs (descriptor-reg) :target res)
105 (data :scs (any-reg immediate zero)))
106 (:arg-types * positive-fixnum)
107 (:results (res :scs (descriptor-reg)))
108 (:temporary (:scs (non-descriptor-reg)) t1 t2)
110 (loadw t1 x 0 other-pointer-lowtag)
111 ;; replace below 2 inst with: (mask widetag-mask t1 t1)
112 (inst li widetag-mask t2)
116 (inst sll data (- n-widetag-bits 2) t2)
119 (inst li (ash (tn-value data) n-widetag-bits) t2)
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 (inst zdep ptr 29 29 res)))
134 (define-vop (make-other-immediate-type)
135 (:args (val :scs (any-reg descriptor-reg))
136 (type :scs (any-reg descriptor-reg immediate) :target temp))
137 (:results (res :scs (any-reg descriptor-reg)))
138 (:temporary (:scs (non-descriptor-reg)) temp)
139 (:temporary (:scs (non-descriptor-reg)) t2)
143 (inst sll val n-widetag-bits temp)
144 (inst li (tn-value type) t2)
145 (inst or temp t2 res))
147 (inst sra type 2 temp)
148 (inst sll val (- n-widetag-bits 2) res)
149 (inst or res temp res)))))
153 (define-vop (dynamic-space-free-pointer)
154 (:results (int :scs (sap-reg)))
155 (:result-types system-area-pointer)
156 (:translate dynamic-space-free-pointer)
159 (move alloc-tn int)))
161 (define-vop (binding-stack-pointer-sap)
162 (:results (int :scs (sap-reg)))
163 (:result-types system-area-pointer)
164 (:translate binding-stack-pointer-sap)
169 (define-vop (control-stack-pointer-sap)
170 (:results (int :scs (sap-reg)))
171 (:result-types system-area-pointer)
172 (:translate control-stack-pointer-sap)
178 ;;;; Code object frobbing.
180 (define-vop (code-instructions)
181 (:translate code-instructions)
183 (:args (code :scs (descriptor-reg)))
184 (:temporary (:scs (non-descriptor-reg)) ndescr)
185 (:results (sap :scs (sap-reg)))
186 (:result-types system-area-pointer)
188 (loadw ndescr code 0 other-pointer-lowtag)
189 (inst srl ndescr n-widetag-bits ndescr)
190 (inst sll ndescr word-shift ndescr)
191 (inst addi (- other-pointer-lowtag) ndescr ndescr)
192 (inst add code ndescr sap)))
194 (define-vop (compute-fun)
195 (:args (code :scs (descriptor-reg))
196 (offset :scs (signed-reg unsigned-reg)))
197 (:arg-types * positive-fixnum)
198 (:results (func :scs (descriptor-reg)))
199 (:temporary (:scs (non-descriptor-reg)) ndescr)
201 (loadw ndescr code 0 other-pointer-lowtag)
202 ;; FIXME-lav: replace below two with DEPW
203 (inst srl ndescr n-widetag-bits ndescr)
204 (inst sll ndescr word-shift ndescr)
205 (inst add ndescr offset ndescr)
206 (inst addi (- fun-pointer-lowtag other-pointer-lowtag) ndescr ndescr)
207 (inst add ndescr code func)))
210 ;;;; Other random VOPs.
213 (defknown sb!unix::receive-pending-interrupt () (values))
214 (define-vop (sb!unix::receive-pending-interrupt)
216 (:translate sb!unix::receive-pending-interrupt)
218 (inst break pending-interrupt-trap)))
223 (inst break halt-trap)))
226 (define-vop (setup-return-from-lisp-stub)
229 (:temporary (:sc any-reg :offset nl0-offset) nl0)
230 (:temporary (:sc any-reg :offset cfunc-offset) cfunc)
231 (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)
232 (:temporary (:scs (non-descriptor-reg)) temp)
235 (let ((stub (make-fixup 'return-from-lisp-stub :assembly-routine)))
237 (let ((cur-nfp (current-nfp-tn vop)))
239 (store-stack-tn nfp-save cur-nfp))
240 (inst li (make-fixup "setup_return_from_lisp_stub" :foreign) cfunc)
241 (let ((fixup (make-fixup "call_into_c" :foreign)))
242 (inst ldil fixup temp)
243 (inst ble fixup c-text-space temp))
244 (inst addi 64 nsp-tn nsp-tn)
245 (inst addi -64 nsp-tn nsp-tn)
247 (load-stack-tn cur-nfp nfp-save)))))
249 ;;;; Dynamic vop count collection support
251 (define-vop (count-me)
252 (:args (count-vector :scs (descriptor-reg)))
254 (:temporary (:scs (non-descriptor-reg)) count)
257 (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag)))
258 (inst ldw offset count-vector count)
259 (inst addi 1 count count)
260 (inst stw count offset count-vector))))