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 (set-fun-subtype)
78 (:translate
(setf fun-subtype
))
80 (:args
(type :scs
(unsigned-reg) :target result
)
81 (function :scs
(descriptor-reg)))
82 (:arg-types positive-fixnum
*)
83 (:results
(result :scs
(unsigned-reg)))
84 (:result-types positive-fixnum
)
86 (inst stb type
(- fun-pointer-lowtag
) function
)
89 (define-vop (get-header-data)
90 (:translate get-header-data
)
92 (:args
(x :scs
(descriptor-reg)))
93 (:results
(res :scs
(unsigned-reg)))
94 (:result-types positive-fixnum
)
96 (loadw res x
0 other-pointer-lowtag
)
97 (inst srl res n-widetag-bits res
)))
99 (define-vop (get-closure-length)
100 (:translate get-closure-length
)
102 (:args
(x :scs
(descriptor-reg)))
103 (:results
(res :scs
(unsigned-reg)))
104 (:result-types positive-fixnum
)
106 (loadw res x
0 fun-pointer-lowtag
)
107 (inst srl res n-widetag-bits res
)))
108 ;;; FIXME-lav, not sure we need data of type immediate and zero, test without,
109 ;;; if so revert to old hppa code
110 (define-vop (set-header-data)
111 (:translate set-header-data
)
113 (:args
(x :scs
(descriptor-reg) :target res
)
114 (data :scs
(any-reg immediate zero
)))
115 (:arg-types
* positive-fixnum
)
116 (:results
(res :scs
(descriptor-reg)))
117 (:temporary
(:scs
(non-descriptor-reg)) t1 t2
)
119 (loadw t1 x
0 other-pointer-lowtag
)
120 ;; replace below 2 inst with: (mask widetag-mask t1 t1)
121 (inst li widetag-mask t2
)
125 (inst sll data
(- n-widetag-bits
2) t2
)
128 (inst li
(ash (tn-value data
) n-widetag-bits
) t2
)
132 (storew t1 x
0 other-pointer-lowtag
)
135 (define-vop (pointer-hash)
136 (:translate pointer-hash
)
137 (:args
(ptr :scs
(any-reg descriptor-reg
)))
138 (:results
(res :scs
(any-reg descriptor-reg
)))
141 (inst zdep ptr n-positive-fixnum-bits n-positive-fixnum-bits res
)))
145 (define-vop (dynamic-space-free-pointer)
146 (:results
(int :scs
(sap-reg)))
147 (:result-types system-area-pointer
)
148 (:translate dynamic-space-free-pointer
)
151 (move alloc-tn int
)))
153 (define-vop (binding-stack-pointer-sap)
154 (:results
(int :scs
(sap-reg)))
155 (:result-types system-area-pointer
)
156 (:translate binding-stack-pointer-sap
)
161 (define-vop (control-stack-pointer-sap)
162 (:results
(int :scs
(sap-reg)))
163 (:result-types system-area-pointer
)
164 (:translate control-stack-pointer-sap
)
170 ;;;; Code object frobbing.
172 (define-vop (code-instructions)
173 (:translate code-instructions
)
175 (:args
(code :scs
(descriptor-reg)))
176 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
177 (:results
(sap :scs
(sap-reg)))
178 (:result-types system-area-pointer
)
180 (loadw ndescr code
0 other-pointer-lowtag
)
181 (inst srl ndescr n-widetag-bits ndescr
)
182 (inst sll ndescr word-shift ndescr
)
183 (inst addi
(- other-pointer-lowtag
) ndescr ndescr
)
184 (inst add code ndescr sap
)))
186 (define-vop (compute-fun)
187 (:args
(code :scs
(descriptor-reg))
188 (offset :scs
(signed-reg unsigned-reg
)))
189 (:arg-types
* positive-fixnum
)
190 (:results
(func :scs
(descriptor-reg)))
191 (:temporary
(:scs
(non-descriptor-reg)) ndescr
)
193 (loadw ndescr code
0 other-pointer-lowtag
)
194 ;; FIXME-lav: replace below two with DEPW
195 (inst srl ndescr n-widetag-bits ndescr
)
196 (inst sll ndescr word-shift ndescr
)
197 (inst add ndescr offset ndescr
)
198 (inst addi
(- fun-pointer-lowtag other-pointer-lowtag
) ndescr ndescr
)
199 (inst add ndescr code func
)))
202 ;;;; Other random VOPs.
205 (defknown sb
!unix
::receive-pending-interrupt
() (values))
206 (define-vop (sb!unix
::receive-pending-interrupt
)
208 (:translate sb
!unix
::receive-pending-interrupt
)
210 (inst break pending-interrupt-trap
)))
215 (inst break halt-trap
)))
218 (define-vop (setup-return-from-lisp-stub)
221 (:temporary
(:sc any-reg
:offset nl0-offset
) nl0
)
222 (:temporary
(:sc any-reg
:offset cfunc-offset
) cfunc
)
223 (:temporary
(:sc control-stack
:offset nfp-save-offset
) nfp-save
)
224 (:temporary
(:scs
(non-descriptor-reg)) temp
)
227 (let ((stub (make-fixup 'return-from-lisp-stub
:assembly-routine
)))
229 (let ((cur-nfp (current-nfp-tn vop
)))
231 (store-stack-tn nfp-save cur-nfp
))
232 (inst li
(make-fixup "setup_return_from_lisp_stub" :foreign
) cfunc
)
233 (let ((fixup (make-fixup "call_into_c" :foreign
)))
234 (inst ldil fixup temp
)
235 (inst ble fixup c-text-space temp
))
236 (inst addi
64 nsp-tn nsp-tn
)
237 (inst addi -
64 nsp-tn nsp-tn
)
239 (load-stack-tn cur-nfp nfp-save
)))))
241 ;;;; Dynamic vop count collection support
243 (define-vop (count-me)
244 (:args
(count-vector :scs
(descriptor-reg)))
246 (:temporary
(:scs
(non-descriptor-reg)) count
)
249 (- (* (+ index vector-data-offset
) n-word-bytes
) other-pointer-lowtag
)))
250 (inst ldw offset count-vector count
)
251 (inst addi
1 count count
)
252 (inst stw count offset count-vector
))))
254 ;;;; Dummy definition for a spin-loop hint VOP
255 (define-vop (spin-loop-hint)
256 (:translate spin-loop-hint
)