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.
15 ;;;; Type frobbing VOPs
17 (define-vop (get-lowtag)
18 (:translate get-lowtag)
20 (:args (object :scs (any-reg descriptor-reg)))
21 (:results (result :scs (unsigned-reg)))
22 (:result-types positive-fixnum)
24 (inst and object lowtag-mask result)))
26 (define-vop (get-type)
29 (:args (object :scs (descriptor-reg)))
30 (:temporary (:scs (non-descriptor-reg)) ndescr)
31 (:results (result :scs (unsigned-reg)))
32 (:result-types positive-fixnum)
34 ;; Pick off objects with headers.
35 (inst and object lowtag-mask result)
36 (inst cmpeq result other-pointer-type ndescr)
37 (inst bne ndescr other-ptr)
38 (inst cmpeq result function-pointer-type ndescr)
39 (inst bne ndescr function-ptr)
41 ;; Pick off structure and list pointers.
42 (inst blbs object done)
45 (inst and object 3 result)
46 (inst beq result done)
48 ;; Must be an other immediate.
49 (inst and object type-mask result)
50 (inst br zero-tn done)
53 (load-type result object (- function-pointer-type))
54 (inst br zero-tn done)
57 (load-type result object (- other-pointer-type))
61 (define-vop (function-subtype)
62 (:translate function-subtype)
64 (:args (function :scs (descriptor-reg)))
65 (:results (result :scs (unsigned-reg)))
66 (:result-types positive-fixnum)
68 (load-type result function (- function-pointer-type))))
70 (define-vop (set-function-subtype)
71 (:translate (setf function-subtype))
73 (:args (type :scs (unsigned-reg) :target result)
74 (function :scs (descriptor-reg)))
75 (:arg-types positive-fixnum *)
76 (:temporary (:scs (non-descriptor-reg)) temp)
77 (:results (result :scs (unsigned-reg)))
78 (:result-types positive-fixnum)
80 (inst ldl temp (- function-pointer-type) function)
81 (inst and temp #xff temp)
82 (inst bis type temp temp)
83 (inst stl temp (- function-pointer-type) function)
87 (define-vop (get-header-data)
88 (:translate get-header-data)
90 (:args (x :scs (descriptor-reg)))
91 (:results (res :scs (unsigned-reg)))
92 (:result-types positive-fixnum)
94 (loadw res x 0 other-pointer-type)
95 (inst srl res type-bits res)))
97 (define-vop (get-closure-length)
98 (:translate get-closure-length)
100 (:args (x :scs (descriptor-reg)))
101 (:results (res :scs (unsigned-reg)))
102 (:result-types positive-fixnum)
104 (loadw res x 0 function-pointer-type)
105 (inst srl res type-bits res)))
107 (define-vop (set-header-data)
108 (:translate set-header-data)
110 (:args (x :scs (descriptor-reg) :target res)
111 (data :scs (any-reg immediate zero)))
112 (:arg-types * positive-fixnum)
113 (:results (res :scs (descriptor-reg)))
114 (:temporary (:scs (non-descriptor-reg)) t1 t2)
116 (loadw t1 x 0 other-pointer-type)
117 (inst and t1 type-mask t1)
120 (inst sll data (- type-bits 2) t2)
123 (let ((c (ash (tn-value data) type-bits)))
124 (cond ((<= 0 c (1- (ash 1 8)))
128 (inst bis t1 t2 t1)))))
130 (storew t1 x 0 other-pointer-type)
133 (define-vop (make-fixnum)
134 (:args (ptr :scs (any-reg descriptor-reg)))
135 (:results (res :scs (any-reg descriptor-reg)))
138 ;; Some code (the hash table code) depends on this returning a
139 ;; positive number so make sure it does.
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 type-bits temp)
153 (inst bis temp (tn-value type) res))
155 (inst sra type 2 temp)
156 (inst sll val (- type-bits 2) 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-type)
198 (inst srl ndescr type-bits ndescr)
199 (inst sll ndescr word-shift ndescr)
200 (inst subq ndescr other-pointer-type ndescr)
201 (inst addq code ndescr sap)))
203 (define-vop (compute-function)
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-type)
211 (inst srl ndescr type-bits ndescr)
212 (inst sll ndescr word-shift ndescr)
213 (inst addq ndescr offset ndescr)
214 (inst subq ndescr (- other-pointer-type function-pointer-type) ndescr)
215 (inst addq code ndescr func)))
218 ;;;; Other random VOPs.
221 (defknown sb!unix::do-pending-interrupt () (values))
222 (define-vop (sb!unix::do-pending-interrupt)
224 (:translate sb!unix::do-pending-interrupt)
226 (inst gentrap pending-interrupt-trap)))
231 (inst gentrap halt-trap)))
234 ;;;; Dynamic vop count collection support
236 (define-vop (count-me)
237 (:args (count-vector :scs (descriptor-reg)))
239 (:temporary (:scs (non-descriptor-reg)) count)
242 (- (* (+ index vector-data-offset) word-bytes) other-pointer-type)))
243 (inst ldl count offset count-vector)
244 (inst addq count 1 count)
245 (inst stl count offset count-vector))))