0.8.17.17:
[sbcl.git] / src / compiler / alpha / cell.lisp
1 ;;;; the VM definition of various primitive memory access VOPs for the
2 ;;;; Alpha
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 null zero)))
28   (:info name offset lowtag #!+gengc remember)
29   (:ignore name)
30   (:results)
31   (:generator 1
32     #!+gengc
33     (if remember
34         (storew-and-remember-slot value object offset lowtag)
35         (storew value object offset lowtag))
36     #!-gengc
37     (storew value object offset lowtag)))
38 \f
39 ;;;; symbol hacking VOPs
40
41 ;;; The compiler likes to be able to directly SET symbols.
42 (define-vop (set cell-set)
43   (:variant symbol-value-slot other-pointer-lowtag))
44
45 ;;; Do a cell ref with an error check for being unbound.
46 (define-vop (checked-cell-ref)
47   (:args (object :scs (descriptor-reg) :target obj-temp))
48   (:results (value :scs (descriptor-reg any-reg)))
49   (:policy :fast-safe)
50   (:vop-var vop)
51   (:save-p :compute-only)
52   (:temporary (:scs (non-descriptor-reg)) temp)
53   (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
54
55 ;;; With SYMBOL-VALUE, we check that the value isn't the trap object.
56 ;;; So SYMBOL-VALUE of NIL is NIL.
57 (define-vop (symbol-value checked-cell-ref)
58   (:translate symbol-value)
59   (:generator 9
60     (move object obj-temp)
61     (loadw value obj-temp symbol-value-slot other-pointer-lowtag)
62     (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
63       (inst xor value unbound-marker-widetag temp)
64       (inst beq temp err-lab))))
65
66 ;;; like CHECKED-CELL-REF, only we are a predicate to see if the cell
67 ;;; is bound
68 (define-vop (boundp-frob)
69   (:args (object :scs (descriptor-reg)))
70   (:conditional)
71   (:info target not-p)
72   (:policy :fast-safe)
73   (:temporary (:scs (descriptor-reg)) value)
74   (:temporary (:scs (non-descriptor-reg)) temp))
75
76 (define-vop (boundp boundp-frob)
77   (:translate boundp)
78   (:generator 9
79     (loadw value object symbol-value-slot other-pointer-lowtag)
80     (inst xor value unbound-marker-widetag temp)
81     (if not-p
82         (inst beq temp target)
83         (inst bne temp target))))
84
85 (define-vop (fast-symbol-value cell-ref)
86   (:variant symbol-value-slot other-pointer-lowtag)
87   (:policy :fast)
88   (:translate symbol-value))
89
90 (define-vop (symbol-hash)
91   (:policy :fast-safe)
92   (:translate symbol-hash)
93   (:args (symbol :scs (descriptor-reg)))
94   (:results (res :scs (any-reg)))
95   (:result-types positive-fixnum)
96   (:generator 2
97     ;; The symbol-hash slot of NIL holds NIL because it is also the
98     ;; cdr slot, so we have to strip off the two low bits to make sure
99     ;; it is a fixnum.  The lowtag selection magic that is required to
100     ;; ensure this is explained in the comment in objdef.lisp
101     (loadw res symbol symbol-hash-slot other-pointer-lowtag)
102     (inst bic res #.(ash lowtag-mask -1) res)))
103 \f
104 ;;;; fdefinition (FDEFN) objects
105
106 (define-vop (fdefn-fun cell-ref)
107   (:variant fdefn-fun-slot other-pointer-lowtag))
108
109 (define-vop (safe-fdefn-fun)
110   (:args (object :scs (descriptor-reg) :target obj-temp))
111   (:results (value :scs (descriptor-reg any-reg)))
112   (:vop-var vop)
113   (:save-p :compute-only)
114   (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
115   (:temporary (:scs (non-descriptor-reg)) temp)
116   (:generator 10
117     (move object obj-temp)
118     (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag)
119     (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp)))
120       (inst cmpeq value null-tn temp)
121       (inst bne temp err-lab))))
122
123 (define-vop (set-fdefn-fun)
124   (:policy :fast-safe)
125   (:translate (setf fdefn-fun))
126   (:args (function :scs (descriptor-reg) :target result)
127          (fdefn :scs (descriptor-reg)))
128   (:temporary (:scs (interior-reg)) lip)
129   (:temporary (:scs (non-descriptor-reg)) type)
130   (:results (result :scs (descriptor-reg)))
131   (:generator 38
132     (let ((normal-fn (gen-label)))
133       (load-type type function (- fun-pointer-lowtag))
134       (inst xor type simple-fun-header-widetag type)
135       (inst addq function
136             (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag)
137             lip)
138       (inst beq type normal-fn)
139       (inst li (make-fixup "closure_tramp" :foreign) lip)
140       (emit-label normal-fn)
141       (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
142       (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
143       (move function result))))
144           
145
146 (define-vop (fdefn-makunbound)
147   (:policy :fast-safe)
148   (:translate fdefn-makunbound)
149   (:args (fdefn :scs (descriptor-reg) :target result))
150   (:temporary (:scs (non-descriptor-reg)) temp)
151   (:results (result :scs (descriptor-reg)))
152   (:generator 38
153     (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag)
154     (inst li (make-fixup "undefined_tramp" :foreign) temp)
155     (move fdefn result)
156     (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)))
157 \f
158 ;;;; binding and Unbinding
159
160 ;;; Establish VAL as a binding for SYMBOL. Save the old value and the
161 ;;; symbol on the binding stack and stuff the new value into the symbol.
162 (define-vop (bind)
163   (:args (val :scs (any-reg descriptor-reg))
164          (symbol :scs (descriptor-reg)))
165   (:temporary (:scs (descriptor-reg)) temp)
166   (:generator 5
167     (loadw temp symbol symbol-value-slot other-pointer-lowtag)
168     (inst addq bsp-tn (* 2 n-word-bytes) bsp-tn)
169     (storew temp bsp-tn (- binding-value-slot binding-size))
170     (storew symbol bsp-tn (- binding-symbol-slot binding-size))
171     (#!+gengc storew-and-remember-slot #!-gengc storew
172              val symbol symbol-value-slot other-pointer-lowtag)))
173
174
175 (define-vop (unbind)
176   (:temporary (:scs (descriptor-reg)) symbol value)
177   (:generator 0
178     (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
179     (loadw value bsp-tn (- binding-value-slot binding-size))
180     (#!+gengc storew-and-remember-slot #!-gengc storew
181              value symbol symbol-value-slot other-pointer-lowtag)
182     (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
183     (inst subq bsp-tn (* 2 n-word-bytes) bsp-tn)))
184
185
186 (define-vop (unbind-to-here)
187   (:args (arg :scs (descriptor-reg any-reg) :target where))
188   (:temporary (:scs (any-reg) :from (:argument 0)) where)
189   (:temporary (:scs (descriptor-reg)) symbol value)
190   (:temporary (:scs (non-descriptor-reg)) temp)
191   (:generator 0
192     (let ((loop (gen-label))
193           (skip (gen-label))
194           (done (gen-label)))
195       (move arg where)
196       (inst cmpeq where bsp-tn temp)
197       (inst bne temp done)
198
199       (emit-label loop)
200       (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
201       (loadw value bsp-tn (- binding-value-slot binding-size))
202       (inst beq symbol skip)
203       (#!+gengc storew-and-remember-slot #!-gengc storew
204                value symbol symbol-value-slot other-pointer-lowtag)
205       (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
206
207       (emit-label skip)
208       (inst subq bsp-tn (* 2 n-word-bytes) bsp-tn)
209       (inst cmpeq where bsp-tn temp)
210       (inst beq temp loop)
211
212       (emit-label done))))
213 \f
214 ;;;; closure indexing
215
216 (define-full-reffer closure-index-ref *
217   closure-info-offset fun-pointer-lowtag
218   (descriptor-reg any-reg) * %closure-index-ref)
219
220 (define-full-setter set-funcallable-instance-info *
221   funcallable-instance-info-offset fun-pointer-lowtag
222   (descriptor-reg any-reg null zero) * %set-funcallable-instance-info)
223
224 (define-full-reffer funcallable-instance-info *
225   funcallable-instance-info-offset fun-pointer-lowtag
226   (descriptor-reg any-reg) * %funcallable-instance-info)
227
228 (define-vop (funcallable-instance-lexenv cell-ref)
229   (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
230
231 (define-vop (closure-ref slot-ref)
232   (:variant closure-info-offset fun-pointer-lowtag))
233
234 (define-vop (closure-init slot-set)
235   (:variant closure-info-offset fun-pointer-lowtag))
236 \f
237 ;;;; value cell hackery
238
239 (define-vop (value-cell-ref cell-ref)
240   (:variant value-cell-value-slot other-pointer-lowtag))
241
242 (define-vop (value-cell-set cell-set)
243   (:variant value-cell-value-slot other-pointer-lowtag))
244 \f
245 ;;;; instance hackery
246
247 (define-vop (instance-length)
248   (:policy :fast-safe)
249   (:translate %instance-length)
250   (:args (struct :scs (descriptor-reg)))
251   (:results (res :scs (unsigned-reg)))
252   (:result-types positive-fixnum)
253   (:generator 4
254     (loadw res struct 0 instance-pointer-lowtag)
255     (inst srl res n-widetag-bits res)))
256
257 (define-vop (instance-ref slot-ref)
258   (:variant instance-slots-offset instance-pointer-lowtag)
259   (:policy :fast-safe)
260   (:translate %instance-ref)
261   (:arg-types instance (:constant index)))
262
263 (define-vop (instance-set slot-set)
264   (:policy :fast-safe)
265   (:translate %instance-set)
266   (:variant instance-slots-offset instance-pointer-lowtag)
267   (:arg-types instance (:constant index) *))
268
269 (define-full-reffer instance-index-ref * instance-slots-offset
270   instance-pointer-lowtag (descriptor-reg any-reg) * %instance-ref)
271
272 (define-full-setter instance-index-set * instance-slots-offset
273   instance-pointer-lowtag (descriptor-reg any-reg null zero) * %instance-set)
274 \f
275 ;;;; code object frobbing
276
277 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
278   (descriptor-reg any-reg) * code-header-ref)
279
280 (define-full-setter code-header-set * 0 other-pointer-lowtag
281   (descriptor-reg any-reg null zero) * code-header-set)
282 \f
283 ;;;; mutator accessing
284
285 #!+gengc
286 (progn
287
288 (eval-when (:compile-toplevel :load-toplevel :execute)
289   ;; SBCL has never had GENGC. Now that we have Alpha support, it
290   ;; would probably be nice to restore GENGC support so that the Alpha
291   ;; doesn't have to crawl along with stop'n'copy. When we do, the CMU
292   ;; CL code below will need updating to the SBCL way of looking at
293   ;; things, e.g. at least using "SB-KERNEL" or "SB!KERNEL" instead of
294   ;; :KERNEL. -- WHN 2001-05-08
295   (error "This code is stale as of sbcl-0.6.12."))
296
297 (define-vop (mutator-ub32-ref)
298   (:policy :fast-safe)
299   (:args)
300   (:results (res :scs (unsigned-reg)))
301   (:result-types unsigned-num)
302   (:variant-vars slot)
303   (:generator 2
304     (loadw res mutator-tn slot)))
305
306 (define-vop (mutator-descriptor-ref mutator-ub32-ref)
307   (:results (res :scs (any-reg descriptor-reg)))
308   (:result-types *))
309
310 (define-vop (mutator-sap-ref mutator-ub32-ref)
311   (:results (res :scs (sap-reg)))
312   (:result-types system-area-pointer))
313
314
315 (define-vop (mutator-ub32-set)
316   (:policy :fast-safe)
317   (:args (arg :scs (unsigned-reg) :target res))
318   (:arg-types unsigned-num)
319   (:results (res :scs (unsigned-reg)))
320   (:result-types unsigned-num)
321   (:variant-vars slot)
322   (:generator 2
323     (storew arg mutator-tn slot)
324     (move res arg)))
325
326 (define-vop (mutator-descriptor-set mutator-ub32-set)
327   (:args (arg :scs (any-reg descriptor-reg null zero) :target res))
328   (:arg-types *)
329   (:results (res :scs (any-reg descriptor-reg)))
330   (:result-types *))
331
332 (define-vop (mutator-sap-set mutator-ub32-set)
333   (:args (arg :scs (sap-reg) :target res))
334   (:arg-types system-area-pointer)
335   (:results (res :scs (sap-reg)))
336   (:result-types system-area-pointer))
337
338
339 (macrolet ((define-mutator-accessors (slot type writable)
340              (let ((ref (symbolicate "MUTATOR-" slot "-REF"))
341                    (set (and writable (symbolicate "MUTATOR-" slot "-SET")))
342                    (offset (symbolicate "MUTATOR-" slot "-SLOT"))
343                    (fn
344                     (let ((*package* (find-package :kernel)))
345              (symbolicate "MUTATOR-" slot))))
346                (multiple-value-bind
347                    (lisp-type ref-vop set-vop)
348                    (ecase type
349                      (:des
350                       (values t
351                               'mutator-descriptor-ref
352                               'mutator-descriptor-set))
353                      (:ub32
354                       (values '(unsigned-byte 32)
355                               'mutator-ub32-ref
356                               'mutator-ub32-set))
357                      (:sap
358                       (values 'system-area-pointer
359                               'mutator-sap-ref
360                               'mutator-sap-set)))
361                  `(progn
362                     (export ',fn :kernel)
363                     (defknown ,fn () ,lisp-type (flushable))
364                     (define-vop (,ref ,ref-vop)
365                       (:translate ,fn)
366                       (:variant ,offset))
367                     ,@(when writable
368                         `((defknown ((setf ,fn)) (,lisp-type) ,lisp-type
369                             (unsafe))
370                           (define-vop (,set ,set-vop)
371                             (:translate (setf ,fn))
372                             (:variant ,offset)))))))))
373   (define-mutator-accessors thread :des t)
374   (define-mutator-accessors suspends-disabled-count :ub32 t)
375   (define-mutator-accessors suspend-pending :ub32 t)
376   (define-mutator-accessors control-stack-base :sap nil)
377   (define-mutator-accessors control-stack-end :sap nil)
378   (define-mutator-accessors current-unwind-protect :sap nil)
379   (define-mutator-accessors current-catch-block :sap nil)
380   (define-mutator-accessors binding-stack-base :sap nil)
381   (define-mutator-accessors binding-stack-end :sap nil)
382   (define-mutator-accessors number-stack-base :sap nil)
383   (define-mutator-accessors number-stack-end :sap nil)
384   (define-mutator-accessors nursery-start :sap nil)
385   (define-mutator-accessors nursery-end :sap nil)
386   (define-mutator-accessors storebuf-start :sap nil)
387   (define-mutator-accessors storebuf-end :sap nil)
388   (define-mutator-accessors words-consed :ub32 nil))
389
390 ); #+gengc progn