77ab3ead51cb9bba44bc8652b370c97a08f1e9af
[sbcl.git] / src / compiler / sparc / system.lisp
1 ;;;; Sparc VM definitions of various system hacking operations
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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.
11
12 (in-package "SB!VM")
13 \f
14 ;;;; type frobbing VOPs
15
16 (define-vop (lowtag-of)
17   (:translate lowtag-of)
18   (:policy :fast-safe)
19   (:args (object :scs (any-reg descriptor-reg)))
20   (:results (result :scs (unsigned-reg)))
21   (:result-types positive-fixnum)
22   (:generator 1
23     (inst and result object lowtag-mask)))
24
25 (define-vop (widetag-of)
26   (:translate widetag-of)
27   (:policy :fast-safe)
28   (:args (object :scs (descriptor-reg) :to (:eval 1)))
29   (:results (result :scs (unsigned-reg) :from (:eval 0)))
30   (:result-types positive-fixnum)
31   (:generator 6
32     ;; Grab the lowtag.
33     (inst andcc result object lowtag-mask)
34     ;; Check for various pointer types.
35     (inst cmp result list-pointer-lowtag)
36     (inst b :eq done)
37     (inst cmp result other-pointer-lowtag)
38     (inst b :eq other-pointer)
39     (inst cmp result fun-pointer-lowtag)
40     (inst b :eq function-pointer)
41     (inst cmp result instance-pointer-lowtag)
42     (inst b :eq done)
43     ;; Okay, it is an immediate.  If fixnum, we want zero.  Otherwise,
44     ;; we want the low 8 bits.
45     (inst andcc zero-tn object #b11)
46     (inst b :eq done)
47     (inst li result 0)
48     ;; It wasn't a fixnum, so get the low 8 bits.
49     (inst b done)
50     (inst and result object widetag-mask)
51     
52     FUNCTION-POINTER
53     (inst b done)
54     (load-type result object (- fun-pointer-lowtag))
55
56     OTHER-POINTER
57     (load-type result object (- other-pointer-lowtag))
58
59     DONE))
60
61
62 (define-vop (fun-subtype)
63   (:translate fun-subtype)
64   (:policy :fast-safe)
65   (:args (function :scs (descriptor-reg)))
66   (:results (result :scs (unsigned-reg)))
67   (:result-types positive-fixnum)
68   (:generator 6
69     (load-type result function (- fun-pointer-lowtag))))
70
71 (define-vop (set-fun-subtype)
72   (:translate (setf fun-subtype))
73   (:policy :fast-safe)
74   (:args (type :scs (unsigned-reg) :target result)
75          (function :scs (descriptor-reg)))
76   (:arg-types positive-fixnum *)
77   (:results (result :scs (unsigned-reg)))
78   (:result-types positive-fixnum)
79   (:generator 6
80     ;; FIXME: I don't understand what this hardcoded 3 is doing
81     ;; here. -- CSR, 2002-02-08
82     (inst stb type function (- 3 fun-pointer-lowtag))
83     (move result type)))
84
85 (define-vop (get-header-data)
86   (:translate get-header-data)
87   (:policy :fast-safe)
88   (:args (x :scs (descriptor-reg)))
89   (:results (res :scs (unsigned-reg)))
90   (:result-types positive-fixnum)
91   (:generator 6
92     (loadw res x 0 other-pointer-lowtag)
93     (inst srl res res n-widetag-bits)))
94
95 (define-vop (get-closure-length)
96   (:translate get-closure-length)
97   (:policy :fast-safe)
98   (:args (x :scs (descriptor-reg)))
99   (:results (res :scs (unsigned-reg)))
100   (:result-types positive-fixnum)
101   (:generator 6
102     (loadw res x 0 fun-pointer-lowtag)
103     (inst srl res res n-widetag-bits)))
104
105 (define-vop (set-header-data)
106   (:translate set-header-data)
107   (:policy :fast-safe)
108   (:args (x :scs (descriptor-reg) :target res)
109          (data :scs (any-reg immediate zero)))
110   (:arg-types * positive-fixnum)
111   (:results (res :scs (descriptor-reg)))
112   (:temporary (:scs (non-descriptor-reg)) t1 t2)
113   (:generator 6
114     (loadw t1 x 0 other-pointer-lowtag)
115     (inst and t1 widetag-mask)
116     (sc-case data
117       (any-reg
118        (inst sll t2 data (- n-widetag-bits 2))
119        (inst or t1 t2))
120       (immediate
121        (inst or t1 (ash (tn-value data) n-widetag-bits)))
122       (zero))
123     (storew t1 x 0 other-pointer-lowtag)
124     (move res x)))
125
126
127 (define-vop (make-fixnum)
128   (:args (ptr :scs (any-reg descriptor-reg)))
129   (:results (res :scs (any-reg descriptor-reg)))
130   (:generator 1
131     ;; FIXME: CMUCL comment:
132     ;; Some code (the hash table code) depends on this returning a
133     ;; positive number so make sure it does.
134     (inst sll res ptr 3)
135     (inst srl res res 1)))
136
137 (define-vop (make-other-immediate-type)
138   (:args (val :scs (any-reg descriptor-reg))
139          (type :scs (any-reg descriptor-reg immediate)
140                :target temp))
141   (:results (res :scs (any-reg descriptor-reg)))
142   (:temporary (:scs (non-descriptor-reg)) temp)
143   (:generator 2
144     (sc-case type
145       (immediate
146        (inst sll temp val n-widetag-bits)
147        (inst or res temp (tn-value type)))
148       (t
149        (inst sra temp type 2)
150        (inst sll res val (- n-widetag-bits 2))
151        (inst or res res temp)))))
152
153 \f
154 ;;;; allocation
155
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)
160   (:policy :fast-safe)
161   (:generator 1
162     (move int alloc-tn)))
163
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)
168   (:policy :fast-safe)
169   (:generator 1
170     (move int bsp-tn)))
171
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)
176   (:policy :fast-safe)
177   (:generator 1
178     (move int csp-tn)))
179
180 \f
181 ;;;; code object frobbing.
182
183 (define-vop (code-instructions)
184   (:translate code-instructions)
185   (:policy :fast-safe)
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)
190   (:generator 10
191     (loadw ndescr code 0 other-pointer-lowtag)
192     (inst srl ndescr n-widetag-bits)
193     (inst sll ndescr word-shift)
194     (inst sub ndescr other-pointer-lowtag)
195     (inst add sap code ndescr)))
196
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)
203   (:generator 10
204     (loadw ndescr code 0 other-pointer-lowtag)
205     (inst srl ndescr n-widetag-bits)
206     (inst sll ndescr word-shift)
207     (inst add ndescr offset)
208     (inst add ndescr (- fun-pointer-lowtag other-pointer-lowtag))
209     (inst add func code ndescr)))
210
211
212 \f
213 ;;;; other random VOPs.
214
215
216 (defknown sb!unix::receive-pending-interrupt () (values))
217 (define-vop (sb!unix::receive-pending-interrupt)
218   (:policy :fast-safe)
219   (:translate sb!unix::receive-pending-interrupt)
220   (:generator 1
221     (inst unimp pending-interrupt-trap)))
222
223
224 (define-vop (halt)
225   (:generator 1
226     (inst unimp halt-trap)))
227
228
229 \f
230 ;;;; dynamic VOP count collection support
231
232 (define-vop (count-me)
233   (:args (count-vector :scs (descriptor-reg)))
234   (:info index)
235   (:temporary (:scs (non-descriptor-reg)) count)
236   (:generator 1
237     (let ((offset
238            (- (* (+ index vector-data-offset) n-word-bytes)
239               other-pointer-lowtag)))
240       (assert (typep offset '(signed-byte 13)))
241       (inst ld count count-vector offset)
242       (inst add count 1)
243       (inst st count count-vector offset))))