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 fixnum-tag-mask 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 (%other-pointer-widetag
)
60 (:translate %other-pointer-widetag
)
62 (:args
(object :scs
(descriptor-reg)))
63 (:results
(result :scs
(unsigned-reg)))
64 (:result-types positive-fixnum
)
66 (load-type result object
(- other-pointer-lowtag
))))
68 (define-vop (fun-subtype)
69 (:translate fun-subtype
)
71 (:args
(function :scs
(descriptor-reg)))
72 (:results
(result :scs
(unsigned-reg)))
73 (:result-types positive-fixnum
)
75 (load-type result function
(- fun-pointer-lowtag
))))
77 (define-vop (get-header-data)
78 (:translate get-header-data
)
80 (:args
(x :scs
(descriptor-reg)))
81 (:results
(res :scs
(unsigned-reg)))
82 (:result-types positive-fixnum
)
84 (loadw res x
0 other-pointer-lowtag
)
85 (inst srl res n-widetag-bits res
)))
87 (define-vop (get-closure-length)
88 (:translate get-closure-length
)
90 (:args
(x :scs
(descriptor-reg)))
91 (:results
(res :scs
(unsigned-reg)))
92 (:result-types positive-fixnum
)
94 (loadw res x
0 fun-pointer-lowtag
)
95 (inst srl res n-widetag-bits res
)))
96 ;;; FIXME-lav, not sure we need data of type immediate and zero, test without,
97 ;;; if so revert to old hppa code
98 (define-vop (set-header-data)
99 (:translate set-header-data
)
101 (:args
(x :scs
(descriptor-reg) :target res
)
102 (data :scs
(any-reg immediate zero
)))
103 (:arg-types
* positive-fixnum
)
104 (:results
(res :scs
(descriptor-reg)))
105 (:temporary
(:scs
(non-descriptor-reg)) t1 t2
)
107 (loadw t1 x
0 other-pointer-lowtag
)
108 ;; replace below 2 inst with: (mask widetag-mask t1 t1)
109 (inst li widetag-mask t2
)
113 (inst sll data
(- n-widetag-bits
2) t2
)
116 (inst li
(ash (tn-value data
) n-widetag-bits
) t2
)
120 (storew t1 x
0 other-pointer-lowtag
)
123 (define-vop (pointer-hash)
124 (:translate pointer-hash
)
125 (:args
(ptr :scs
(any-reg descriptor-reg
)))
126 (:results
(res :scs
(any-reg descriptor-reg
)))
129 (inst zdep ptr n-positive-fixnum-bits n-positive-fixnum-bits res
)))
133 (define-vop (dynamic-space-free-pointer)
134 (:results
(int :scs
(sap-reg)))
135 (:result-types system-area-pointer
)
136 (:translate dynamic-space-free-pointer
)
139 (move alloc-tn int
)))
141 (define-vop (binding-stack-pointer-sap)
142 (:results
(int :scs
(sap-reg)))
143 (:result-types system-area-pointer
)
144 (:translate binding-stack-pointer-sap
)
149 (define-vop (control-stack-pointer-sap)
150 (:results
(int :scs
(sap-reg)))
151 (:result-types system-area-pointer
)
152 (:translate control-stack-pointer-sap
)
158 ;;;; Code object frobbing.
160 (define-vop (code-instructions)
161 (:translate code-instructions
)
163 (:args
(code :scs
(descriptor-reg)))
164 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
165 (:results
(sap :scs
(sap-reg)))
166 (:result-types system-area-pointer
)
168 (loadw ndescr code
0 other-pointer-lowtag
)
169 (inst srl ndescr n-widetag-bits ndescr
)
170 (inst sll ndescr word-shift ndescr
)
171 (inst addi
(- other-pointer-lowtag
) ndescr ndescr
)
172 (inst add code ndescr sap
)))
174 (define-vop (compute-fun)
175 (:args
(code :scs
(descriptor-reg))
176 (offset :scs
(signed-reg unsigned-reg
)))
177 (:arg-types
* positive-fixnum
)
178 (:results
(func :scs
(descriptor-reg)))
179 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
181 (loadw ndescr code
0 other-pointer-lowtag
)
182 ;; FIXME-lav: replace below two with DEPW
183 (inst srl ndescr n-widetag-bits ndescr
)
184 (inst sll ndescr word-shift ndescr
)
185 (inst add ndescr offset ndescr
)
186 (inst addi
(- fun-pointer-lowtag other-pointer-lowtag
) ndescr ndescr
)
187 (inst add ndescr code func
)))
190 ;;;; Other random VOPs.
193 (defknown sb
!unix
::receive-pending-interrupt
() (values))
194 (define-vop (sb!unix
::receive-pending-interrupt
)
196 (:translate sb
!unix
::receive-pending-interrupt
)
198 (inst break pending-interrupt-trap
)))
203 (inst break halt-trap
)))
206 (define-vop (setup-return-from-lisp-stub)
209 (:temporary
(:sc any-reg
:offset nl0-offset
) nl0
)
210 (:temporary
(:sc any-reg
:offset cfunc-offset
) cfunc
)
211 (:temporary
(:sc control-stack
:offset nfp-save-offset
) nfp-save
)
212 (:temporary
(:scs
(non-descriptor-reg)) temp
)
215 (let ((stub (make-fixup 'return-from-lisp-stub
:assembly-routine
)))
217 (let ((cur-nfp (current-nfp-tn vop
)))
219 (store-stack-tn nfp-save cur-nfp
))
220 (inst li
(make-fixup "setup_return_from_lisp_stub" :foreign
) cfunc
)
221 (let ((fixup (make-fixup "call_into_c" :foreign
)))
222 (inst ldil fixup temp
)
223 (inst ble fixup c-text-space temp
))
224 (inst addi
64 nsp-tn nsp-tn
)
225 (inst addi -
64 nsp-tn nsp-tn
)
227 (load-stack-tn cur-nfp nfp-save
)))))
229 ;;;; Dynamic vop count collection support
231 (define-vop (count-me)
232 (:args
(count-vector :scs
(descriptor-reg)))
234 (:temporary
(:scs
(non-descriptor-reg)) count
)
237 (- (* (+ index vector-data-offset
) n-word-bytes
) other-pointer-lowtag
)))
238 (inst ldw offset count-vector count
)
239 (inst addi
1 count count
)
240 (inst stw count offset count-vector
))))
242 ;;;; Dummy definition for a spin-loop hint VOP
243 (define-vop (spin-loop-hint)
244 (:translate spin-loop-hint
)