1.0.19.16: derive the type of (AREF (THE STRING X) Y) as CHARACTER
[sbcl.git] / src / compiler / hppa / cell.lisp
1 ;;;; the VM definition of various primitive memory access VOPs for
2 ;;;; HPPA
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
12
13 (in-package "SB!VM")
14 \f
15 ;;;; Data object ref/set stuff.
16
17 (define-vop (slot)
18   (:args (object :scs (descriptor-reg)))
19   (:info name offset lowtag)
20   (:ignore name)
21   (:results (result :scs (descriptor-reg any-reg)))
22   (:generator 1
23     (loadw result object offset lowtag)))
24
25 (define-vop (set-slot)
26   (:args (object :scs (descriptor-reg))
27          (value :scs (descriptor-reg any-reg)))
28   (:info name offset lowtag)
29   (:ignore name)
30   (:results)
31   (:generator 1
32     (storew value object offset lowtag)))
33 \f
34 ;;;; Symbol hacking VOPs:
35
36 ;;; The compiler likes to be able to directly SET symbols.
37 (define-vop (set cell-set)
38   (:variant symbol-value-slot other-pointer-lowtag))
39
40 ;;; Do a cell ref with an error check for being unbound.
41 (define-vop (checked-cell-ref)
42   (:args (object :scs (descriptor-reg) :target obj-temp))
43   (:results (value :scs (descriptor-reg any-reg)))
44   (:policy :fast-safe)
45   (:vop-var vop)
46   (:save-p :compute-only)
47   (:temporary (:type random  :scs (non-descriptor-reg)) temp)
48   (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
49
50 ;;; With Symbol-Value, we check that the value isn't the trap object.  So
51 ;;; Symbol-Value of NIL is NIL.
52 (define-vop (symbol-value checked-cell-ref)
53   (:translate symbol-value)
54   (:generator 9
55     (move object obj-temp)
56     (loadw value obj-temp symbol-value-slot other-pointer-lowtag)
57     (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
58       (inst li unbound-marker-widetag temp)
59       (inst bc := nil value temp err-lab))))
60
61 ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound.
62 (define-vop (boundp-frob)
63   (:args (object :scs (descriptor-reg)))
64   (:conditional)
65   (:info target not-p)
66   (:policy :fast-safe)
67   (:temporary (:scs (descriptor-reg)) value)
68   (:temporary (:type random  :scs (non-descriptor-reg)) temp))
69
70 (define-vop (boundp boundp-frob)
71   (:translate boundp)
72   (:generator 9
73     (loadw value object symbol-value-slot other-pointer-lowtag)
74     (inst li unbound-marker-widetag temp)
75     (inst bc :<> not-p value temp target)))
76
77 (define-vop (fast-symbol-value cell-ref)
78   (:variant symbol-value-slot other-pointer-lowtag)
79   (:policy :fast)
80   (:translate symbol-value))
81
82 (define-vop (symbol-hash)
83   (:policy :fast-safe)
84   (:translate symbol-hash)
85   (:args (symbol :scs (descriptor-reg)))
86   (:results (res :scs (any-reg)))
87   (:result-types positive-fixnum)
88   (:generator 2
89     ;; The symbol-hash slot of NIL holds NIL because it is also the
90     ;; cdr slot, so we have to strip off the two low bits to make sure
91     ;; it is a fixnum.  The lowtag selection magic that is required to
92     ;; ensure this is explained in the comment in objdef.lisp
93     (loadw res symbol symbol-hash-slot other-pointer-lowtag)
94     (inst andcm res #b11 res)))
95 \f
96 ;;;; Fdefinition (fdefn) objects.
97
98 (define-vop (fdefn-fun cell-ref)
99   (:variant fdefn-fun-slot other-pointer-lowtag))
100
101 (define-vop (safe-fdefn-fun)
102   (:args (object :scs (descriptor-reg) :target obj-temp))
103   (:results (value :scs (descriptor-reg any-reg)))
104   (:vop-var vop)
105   (:save-p :compute-only)
106   (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
107   (:generator 10
108     (move obj-temp object)
109     (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag)
110     (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp)))
111       (inst bc := nil value null-tn err-lab))))
112
113 (define-vop (set-fdefn-fun)
114   (:policy :fast-safe)
115   (:translate (setf fdefn-fun))
116   (:args (function :scs (descriptor-reg) :target result)
117          (fdefn :scs (descriptor-reg)))
118   (:temporary (:scs (interior-reg)) lip)
119   (:temporary (:scs (non-descriptor-reg)) type)
120   (:results (result :scs (descriptor-reg)))
121   (:generator 38
122     (load-type type function (- fun-pointer-lowtag))
123     (inst addi (- simple-fun-header-widetag) type type)
124     (inst comb := type zero-tn normal-fn)
125     (inst addi (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)
126           function lip)
127     (inst li (make-fixup "closure_tramp" :foreign) lip)
128     NORMAL-FN
129     (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
130     (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
131     (move function result)))
132
133 (define-vop (fdefn-makunbound)
134   (:policy :fast-safe)
135   (:translate fdefn-makunbound)
136   (:args (fdefn :scs (descriptor-reg) :target result))
137   (:temporary (:scs (non-descriptor-reg)) temp)
138   (:results (result :scs (descriptor-reg)))
139   (:generator 38
140     (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag)
141     (inst li (make-fixup "undefined_tramp" :foreign) temp)
142     (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
143     (move fdefn result)))
144
145
146 \f
147 ;;;; Binding and Unbinding.
148
149 ;;; BIND -- Establish VAL as a binding for SYMBOL.  Save the old value and
150 ;;; the symbol on the binding stack and stuff the new value into the
151 ;;; symbol.
152
153 (define-vop (bind)
154   (:args (val :scs (any-reg descriptor-reg))
155          (symbol :scs (descriptor-reg)))
156   (:temporary (:scs (descriptor-reg)) temp)
157   (:generator 5
158     (loadw temp symbol symbol-value-slot other-pointer-lowtag)
159     (inst addi (* binding-size n-word-bytes) bsp-tn bsp-tn)
160     (storew temp bsp-tn (- binding-value-slot binding-size))
161     (storew symbol bsp-tn (- binding-symbol-slot binding-size))
162     (storew val symbol symbol-value-slot other-pointer-lowtag)))
163
164 (define-vop (unbind)
165   (:temporary (:scs (descriptor-reg)) symbol value)
166   (:generator 0
167     (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
168     (loadw value bsp-tn (- binding-value-slot binding-size))
169     (storew value symbol symbol-value-slot other-pointer-lowtag)
170     (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
171     (storew zero-tn bsp-tn (- binding-value-slot binding-size))
172     (inst addi (- (* binding-size n-word-bytes)) bsp-tn bsp-tn)))
173
174 (define-vop (unbind-to-here)
175   (:args (where :scs (descriptor-reg any-reg)))
176   (:temporary (:scs (descriptor-reg)) symbol value)
177   (:generator 0
178     (inst comb := where bsp-tn done :nullify t)
179     (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
180
181     LOOP
182     (inst comb := symbol zero-tn skip)
183     (loadw value bsp-tn (- binding-value-slot binding-size))
184     (storew value symbol symbol-value-slot other-pointer-lowtag)
185     (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
186
187     SKIP
188     (storew zero-tn bsp-tn (- binding-value-slot binding-size))
189     (inst addi (* -2 n-word-bytes) bsp-tn bsp-tn)
190     (inst comb :<> where bsp-tn loop :nullify t)
191     (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
192
193     DONE))
194
195
196 \f
197 ;;;; Closure indexing.
198
199 (define-full-reffer closure-index-ref *
200   closure-info-offset fun-pointer-lowtag
201   (descriptor-reg any-reg) * %closure-index-ref)
202
203 (define-full-setter set-funcallable-instance-info *
204   funcallable-instance-info-offset fun-pointer-lowtag
205   (descriptor-reg any-reg) * %set-funcallable-instance-info)
206
207 (define-full-reffer funcallable-instance-info *
208   funcallable-instance-info-offset fun-pointer-lowtag
209   (descriptor-reg any-reg) * %funcallable-instance-info)
210
211 (define-vop (closure-ref slot-ref)
212   (:variant closure-info-offset fun-pointer-lowtag))
213
214 (define-vop (closure-init slot-set)
215   (:variant closure-info-offset fun-pointer-lowtag))
216 \f
217 ;;;; Value Cell hackery.
218
219 (define-vop (value-cell-ref cell-ref)
220   (:variant value-cell-value-slot other-pointer-lowtag))
221
222 (define-vop (value-cell-set cell-set)
223   (:variant value-cell-value-slot other-pointer-lowtag))
224
225
226 \f
227 ;;;; Instance hackery:
228
229 (define-vop (instance-length)
230   (:policy :fast-safe)
231   (:translate %instance-length)
232   (:args (struct :scs (descriptor-reg)))
233   (:results (res :scs (unsigned-reg)))
234   (:result-types positive-fixnum)
235   (:generator 4
236     (loadw res struct 0 instance-pointer-lowtag)
237     (inst srl res n-widetag-bits res)))
238
239 (define-full-reffer instance-index-ref * instance-slots-offset
240   instance-pointer-lowtag (descriptor-reg any-reg) * %instance-ref)
241
242 (define-full-setter instance-index-set * instance-slots-offset
243   instance-pointer-lowtag (descriptor-reg any-reg) * %instance-set)
244
245
246 \f
247 ;;;; Code object frobbing.
248
249 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
250   (descriptor-reg any-reg) * code-header-ref)
251
252 (define-full-setter code-header-set * 0 other-pointer-lowtag
253   (descriptor-reg any-reg) * code-header-set)