1.0.19.16: derive the type of (AREF (THE STRING X) Y) as CHARACTER
[sbcl.git] / src / compiler / hppa / system.lisp
1 (in-package "SB!VM")
2
3 \f
4 ;;;; Type frobbing VOPs
5
6 (define-vop (lowtag-of)
7   (:translate lowtag-of)
8   (:policy :fast-safe)
9   (:args (object :scs (any-reg descriptor-reg) :target result))
10   (:results (result :scs (unsigned-reg)))
11   (:result-types positive-fixnum)
12   (:generator 1
13     (inst extru object 31 3 result)))
14
15 (define-vop (widetag-of)
16   (:translate widetag-of)
17   (:policy :fast-safe)
18   (:args (object :scs (descriptor-reg) :to (:eval 1)))
19   (:results (result :scs (unsigned-reg) :from (:eval 0)))
20   (:result-types positive-fixnum)
21   (:generator 6
22     (inst extru object 31 3 result)
23     (inst comib := other-pointer-lowtag result other-ptr :nullify t)
24     (inst comib := fun-pointer-lowtag result function-ptr :nullify t)
25     (inst bb t object 31 done :nullify t)
26     (inst extru object 31 2 result :=)
27     (inst extru object 31 8 result)
28     (inst nop :tr)
29
30     FUNCTION-PTR
31     (load-type result object (- fun-pointer-lowtag))
32     (inst nop :tr)
33
34     OTHER-PTR
35     (load-type result object (- other-pointer-lowtag))
36
37     DONE))
38
39 (define-vop (fun-subtype)
40   (:translate fun-subtype)
41   (:policy :fast-safe)
42   (:args (function :scs (descriptor-reg)))
43   (:results (result :scs (unsigned-reg)))
44   (:result-types positive-fixnum)
45   (:generator 6
46     (load-type result function (- fun-pointer-lowtag))))
47
48 (define-vop (set-fun-subtype)
49   (:translate (setf fun-subtype))
50   (:policy :fast-safe)
51   (:args (type :scs (unsigned-reg) :target result)
52          (function :scs (descriptor-reg)))
53   (:arg-types positive-fixnum *)
54   (:results (result :scs (unsigned-reg)))
55   (:result-types positive-fixnum)
56   (:generator 6
57     (inst stb type (- 3 fun-pointer-lowtag) function)
58     (move type result)))
59
60 (define-vop (get-header-data)
61   (:translate get-header-data)
62   (:policy :fast-safe)
63   (:args (x :scs (descriptor-reg)))
64   (:results (res :scs (unsigned-reg)))
65   (:result-types positive-fixnum)
66   (:generator 6
67     (loadw res x 0 other-pointer-lowtag)
68     (inst srl res 8 res)))
69
70 (define-vop (get-closure-length)
71   (:translate get-closure-length)
72   (:policy :fast-safe)
73   (:args (x :scs (descriptor-reg)))
74   (:results (res :scs (unsigned-reg)))
75   (:result-types positive-fixnum)
76   (:generator 6
77     (loadw res x 0 fun-pointer-lowtag)
78     (inst srl res 8 res)))
79
80 (define-vop (set-header-data)
81   (:translate set-header-data)
82   (:policy :fast-safe)
83   (:args (x :scs (descriptor-reg) :target res)
84          (data :scs (unsigned-reg)))
85   (:arg-types * positive-fixnum)
86   (:results (res :scs (descriptor-reg)))
87   (:temporary (:scs (non-descriptor-reg)) temp)
88   (:generator 6
89     (loadw temp x 0 other-pointer-lowtag)
90     (inst dep data 23 24 temp)
91     (storew temp x 0 other-pointer-lowtag)
92     (move x res)))
93
94 (define-vop (set-header-data-c)
95   (:translate set-header-data)
96   (:policy :fast-safe)
97   (:args (x :scs (descriptor-reg) :target res))
98   (:arg-types * (:constant (signed-byte 5)))
99   (:info data)
100   (:results (res :scs (descriptor-reg)))
101   (:temporary (:scs (non-descriptor-reg)) temp)
102   (:generator 5
103     (loadw temp x 0 other-pointer-lowtag)
104     (inst dep data 23 24 temp)
105     (storew temp x 0 other-pointer-lowtag)
106     (move x res)))
107
108 (define-vop (pointer-hash)
109   (:translate pointer-hash)
110   (:args (ptr :scs (any-reg descriptor-reg)))
111   (:results (res :scs (any-reg descriptor-reg)))
112   (:policy :fast-safe)
113   (:generator 1
114     ;; FIXME: It would be better if this would mask the lowtag,
115     ;; and shift the result into a positive fixnum like on x86.
116     (inst zdep ptr 29 29 res)))
117
118 (define-vop (make-other-immediate-type)
119   (:args (val :scs (any-reg descriptor-reg))
120          (type :scs (any-reg descriptor-reg) :target temp))
121   (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
122   (:temporary (:scs (non-descriptor-reg)) temp)
123   (:generator 2
124     (inst sll val (- n-widetag-bits 2) res)
125     (inst sra type 2 temp)
126     (inst or res temp res)))
127
128 \f
129 ;;;; Allocation
130
131 (define-vop (dynamic-space-free-pointer)
132   (:results (int :scs (sap-reg)))
133   (:result-types system-area-pointer)
134   (:translate dynamic-space-free-pointer)
135   (:policy :fast-safe)
136   (:generator 1
137     (move alloc-tn int)))
138
139 (define-vop (binding-stack-pointer-sap)
140   (:results (int :scs (sap-reg)))
141   (:result-types system-area-pointer)
142   (:translate binding-stack-pointer-sap)
143   (:policy :fast-safe)
144   (:generator 1
145     (move bsp-tn int)))
146
147 (define-vop (control-stack-pointer-sap)
148   (:results (int :scs (sap-reg)))
149   (:result-types system-area-pointer)
150   (:translate control-stack-pointer-sap)
151   (:policy :fast-safe)
152   (:generator 1
153     (move csp-tn int)))
154
155 \f
156 ;;;; Code object frobbing.
157
158 (define-vop (code-instructions)
159   (:translate code-instructions)
160   (:policy :fast-safe)
161   (:args (code :scs (descriptor-reg)))
162   (:temporary (:scs (non-descriptor-reg)) ndescr)
163   (:results (sap :scs (sap-reg)))
164   (:result-types system-area-pointer)
165   (:generator 10
166     (loadw ndescr code 0 other-pointer-lowtag)
167     (inst srl ndescr 8 ndescr)
168     (inst sll ndescr 2 ndescr)
169     (inst addi (- other-pointer-lowtag) ndescr ndescr)
170     (inst add code ndescr sap)))
171
172 (define-vop (compute-fun)
173   (:args (code :scs (descriptor-reg))
174          (offset :scs (signed-reg unsigned-reg)))
175   (:arg-types * positive-fixnum)
176   (:results (func :scs (descriptor-reg)))
177   (:temporary (:scs (non-descriptor-reg)) ndescr)
178   (:generator 10
179     (loadw ndescr code 0 other-pointer-lowtag)
180     (inst srl ndescr 8 ndescr)
181     (inst sll ndescr 2 ndescr)
182     (inst add ndescr offset ndescr)
183     (inst addi (- fun-pointer-lowtag other-pointer-lowtag) ndescr ndescr)
184     (inst add ndescr code func)))
185
186 \f
187 ;;;; Other random VOPs.
188
189
190 (defknown sb!unix::receive-pending-interrupt () (values))
191 (define-vop (sb!unix::receive-pending-interrupt)
192   (:policy :fast-safe)
193   (:translate sb!unix::receive-pending-interrupt)
194   (:generator 1
195     (inst break pending-interrupt-trap)))
196
197
198 (define-vop (halt)
199   (:generator 1
200     (inst break halt-trap)))
201
202 \f
203 ;;;; Dynamic vop count collection support
204
205 (define-vop (count-me)
206   (:args (count-vector :scs (descriptor-reg)))
207   (:info index)
208   (:temporary (:scs (non-descriptor-reg)) count)
209   (:generator 1
210     (let ((offset
211            (- (* (+ index vector-data-offset) n-word-bytes) other-pointer-lowtag)))
212       (inst ldw offset count-vector count)
213       (inst addi 1 count count)
214       (inst stw count offset count-vector))))