0.9.9.33:
[sbcl.git] / src / compiler / sparc / cell.lisp
1 ;;;; the VM definition of various primitive memory access VOPs for the
2 ;;;; Sparc
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 (define-vop (slot)
17   (:args (object :scs (descriptor-reg)))
18   (:info name offset lowtag)
19   (:ignore name)
20   (:results (result :scs (descriptor-reg any-reg)))
21   (:generator 1
22     (loadw result object offset lowtag)))
23
24 (define-vop (set-slot)
25   (:args (object :scs (descriptor-reg))
26          (value :scs (descriptor-reg any-reg)))
27   (:info name offset lowtag)
28   (:ignore name)
29   (:results)
30   (:generator 1
31     (storew value object offset lowtag)))
32 \f
33 ;;;; Symbol hacking VOPs:
34
35 ;;; The compiler likes to be able to directly SET symbols.
36 (define-vop (set cell-set)
37   (:variant symbol-value-slot other-pointer-lowtag))
38
39 ;;; Do a cell ref with an error check for being unbound.
40 (define-vop (checked-cell-ref)
41   (:args (object :scs (descriptor-reg) :target obj-temp))
42   (:results (value :scs (descriptor-reg any-reg)))
43   (:policy :fast-safe)
44   (:vop-var vop)
45   (:save-p :compute-only)
46   (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
47
48 ;;; With Symbol-Value, we check that the value isn't the trap object.
49 ;;; So Symbol-Value of NIL is NIL.
50 (define-vop (symbol-value checked-cell-ref)
51   (:translate symbol-value)
52   (:generator 9
53     (move obj-temp object)
54     (loadw value obj-temp symbol-value-slot other-pointer-lowtag)
55     (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
56       (inst cmp value unbound-marker-widetag)
57       (inst b :eq err-lab)
58       (inst nop))))
59
60 ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell
61 ;;; 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
69 (define-vop (boundp boundp-frob)
70   (:translate boundp)
71   (:generator 9
72     (loadw value object symbol-value-slot other-pointer-lowtag)
73     (inst cmp value unbound-marker-widetag)
74     (inst b (if not-p :eq :ne) target)
75     (inst nop)))
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 andn res res fixnum-tag-mask)))
95 \f
96 ;;;; FDEFINITION (fdefn) objects.
97 (define-vop (fdefn-fun cell-ref)
98   (:variant fdefn-fun-slot other-pointer-lowtag))
99
100 (define-vop (safe-fdefn-fun)
101   (:args (object :scs (descriptor-reg) :target obj-temp))
102   (:results (value :scs (descriptor-reg any-reg)))
103   (:vop-var vop)
104   (:save-p :compute-only)
105   (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
106   (:generator 10
107     (move obj-temp object)
108     (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag)
109     (inst cmp value null-tn)
110     (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp)))
111       (inst b :eq err-lab))
112     (inst nop)))
113
114 (define-vop (set-fdefn-fun)
115   (:policy :fast-safe)
116   (:translate (setf fdefn-fun))
117   (:args (function :scs (descriptor-reg) :target result)
118          (fdefn :scs (descriptor-reg)))
119   (:temporary (:scs (interior-reg)) lip)
120   (:temporary (:scs (non-descriptor-reg)) type)
121   (:results (result :scs (descriptor-reg)))
122   (:generator 38
123     (let ((normal-fn (gen-label)))
124       (load-type type function (- fun-pointer-lowtag))
125       (inst cmp type simple-fun-header-widetag)
126       (inst b :eq normal-fn)
127       (inst move lip function)
128       (inst li lip (make-fixup "closure_tramp" :foreign))
129       (emit-label normal-fn)
130       (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
131       (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
132       (move result function))))
133
134 (define-vop (fdefn-makunbound)
135   (:policy :fast-safe)
136   (:translate fdefn-makunbound)
137   (:args (fdefn :scs (descriptor-reg) :target result))
138   (:temporary (:scs (non-descriptor-reg)) temp)
139   (:results (result :scs (descriptor-reg)))
140   (:generator 38
141     (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag)
142     (inst li temp (make-fixup "undefined_tramp" :foreign))
143     (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
144     (move result fdefn)))
145
146
147 \f
148 ;;;; Binding and Unbinding.
149
150 ;;; Establish VAL as a binding for SYMBOL.  Save the old value and the
151 ;;; symbol on the binding stack and stuff the new value into the
152 ;;; symbol.
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 add bsp-tn bsp-tn (* 2 n-word-bytes))
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-value-slot binding-size))
171     (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
172     (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))))
173
174 (define-vop (unbind-to-here)
175   (:args (arg :scs (descriptor-reg any-reg) :target where))
176   (:temporary (:scs (any-reg) :from (:argument 0)) where)
177   (:temporary (:scs (descriptor-reg)) symbol value)
178   (:generator 0
179     (let ((loop (gen-label))
180           (skip (gen-label))
181           (done (gen-label)))
182       (move where arg)
183       (inst cmp where bsp-tn)
184       (inst b :eq done)
185       (inst nop)
186
187       (emit-label loop)
188       (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
189       (inst cmp symbol)
190       (inst b :eq skip)
191       (loadw value bsp-tn (- binding-value-slot binding-size))
192       (storew value symbol symbol-value-slot other-pointer-lowtag)
193       (storew zero-tn bsp-tn (- binding-value-slot binding-size))
194       (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
195
196       (emit-label skip)
197       (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))
198       (inst cmp where bsp-tn)
199       (inst b :ne loop)
200       (inst nop)
201
202       (emit-label done))))
203 \f
204 ;;;; closure indexing.
205
206 (define-vop (closure-index-ref word-index-ref)
207   (:variant closure-info-offset fun-pointer-lowtag)
208   (:translate %closure-index-ref))
209
210 (define-vop (funcallable-instance-info word-index-ref)
211   (:variant funcallable-instance-info-offset fun-pointer-lowtag)
212   (:translate %funcallable-instance-info))
213
214 (define-vop (set-funcallable-instance-info word-index-set)
215   (:variant funcallable-instance-info-offset fun-pointer-lowtag)
216   (:translate %set-funcallable-instance-info))
217
218 (define-vop (funcallable-instance-lexenv cell-ref)
219   (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
220
221
222 (define-vop (closure-ref slot-ref)
223   (:variant closure-info-offset fun-pointer-lowtag))
224
225 (define-vop (closure-init slot-set)
226   (:variant closure-info-offset fun-pointer-lowtag))
227 \f
228 ;;;; value cell hackery.
229
230 (define-vop (value-cell-ref cell-ref)
231   (:variant value-cell-value-slot other-pointer-lowtag))
232
233 (define-vop (value-cell-set cell-set)
234   (:variant value-cell-value-slot other-pointer-lowtag))
235 \f
236 ;;;; instance hackery:
237
238 (define-vop (instance-length)
239   (:policy :fast-safe)
240   (:translate %instance-length)
241   (:args (struct :scs (descriptor-reg)))
242   (:temporary (:scs (non-descriptor-reg)) temp)
243   (:results (res :scs (unsigned-reg)))
244   (:result-types positive-fixnum)
245   (:generator 4
246     (loadw temp struct 0 instance-pointer-lowtag)
247     (inst srl res temp n-widetag-bits)))
248
249 (define-vop (instance-ref slot-ref)
250   (:variant instance-slots-offset instance-pointer-lowtag)
251   (:policy :fast-safe)
252   (:translate %instance-ref)
253   (:arg-types * (:constant index)))
254
255 ;;; This VOP has no :results; however, %instance-set must return a
256 ;;; value. This caused, in the forward port to 0.7.x, an error in
257 ;;; !fdefn-cold-init: "argument X is not a REAL: NIL". This VOP is
258 ;;; commented out for now, pending the addition of checking code to
259 ;;; the define-vop machinery to ascertain that this was indeed the
260 ;;; problem. -- CSR, 2002-02-12
261 #+nil
262 (define-vop (instance-set slot-set)
263   (:policy :fast-safe)
264   (:translate %instance-set)
265   (:variant instance-slots-offset instance-pointer-lowtag)
266   (:arg-types * (:constant index) *))
267
268 (define-vop (instance-index-ref word-index-ref)
269   (:policy :fast-safe)
270   (:translate %instance-ref)
271   (:variant instance-slots-offset instance-pointer-lowtag)
272   (:arg-types * positive-fixnum))
273
274 (define-vop (instance-index-set word-index-set)
275   (:policy :fast-safe)
276   (:translate %instance-set)
277   (:variant instance-slots-offset instance-pointer-lowtag)
278   (:arg-types * positive-fixnum *))
279 \f
280 ;;;; Code object frobbing.
281
282 (define-vop (code-header-ref word-index-ref)
283   (:translate code-header-ref)
284   (:policy :fast-safe)
285   (:variant 0 other-pointer-lowtag))
286
287 (define-vop (code-header-set word-index-set)
288   (:translate code-header-set)
289   (:policy :fast-safe)
290   (:variant 0 other-pointer-lowtag))
291
292
293 \f
294 ;;;; raw instance slot accessors
295
296 (define-vop (raw-instance-ref/word)
297   (:translate %raw-instance-ref/word)
298   (:policy :fast-safe)
299   (:args (object :scs (descriptor-reg))
300          (index :scs (any-reg)))
301   (:arg-types * positive-fixnum)
302   (:results (value :scs (unsigned-reg)))
303   (:temporary (:scs (non-descriptor-reg)) offset)
304   (:result-types unsigned-num)
305   (:generator 5
306     (loadw offset object 0 instance-pointer-lowtag)
307     (inst srl offset offset n-widetag-bits)
308     (inst sll offset offset 2)
309     (inst sub offset offset index)
310     (inst add
311           offset
312           offset
313           (- (* (1- instance-slots-offset) n-word-bytes)
314              instance-pointer-lowtag))
315     (inst ld value object offset)))
316
317 (define-vop (raw-instance-set/word)
318   (:translate %raw-instance-set/word)
319   (:policy :fast-safe)
320   (:args (object :scs (descriptor-reg))
321          (index :scs (any-reg))
322          (value :scs (unsigned-reg)))
323   (:arg-types * positive-fixnum unsigned-num)
324   (:results (result :scs (unsigned-reg)))
325   (:temporary (:scs (non-descriptor-reg)) offset)
326   (:result-types unsigned-num)
327   (:generator 5
328     (loadw offset object 0 instance-pointer-lowtag)
329     (inst srl offset offset n-widetag-bits)
330     (inst sll offset offset 2)
331     (inst sub offset offset index)
332     (inst add
333           offset
334           offset
335           (- (* (1- instance-slots-offset) n-word-bytes)
336              instance-pointer-lowtag))
337     (inst st value object offset)
338     (move result value)))
339
340 (define-vop (raw-instance-ref/single)
341   (:translate %raw-instance-ref/single)
342   (:policy :fast-safe)
343   (:args (object :scs (descriptor-reg))
344          (index :scs (any-reg)))
345   (:arg-types * positive-fixnum)
346   (:results (value :scs (single-reg)))
347   (:temporary (:scs (non-descriptor-reg)) offset)
348   (:result-types single-float)
349   (:generator 5
350     (loadw offset object 0 instance-pointer-lowtag)
351     (inst srl offset offset n-widetag-bits)
352     (inst sll offset offset 2)
353     (inst sub offset offset index)
354     (inst add
355           offset
356           offset
357           (- (* (1- instance-slots-offset) n-word-bytes)
358              instance-pointer-lowtag))
359     (inst ldf value object offset)))
360
361 (define-vop (raw-instance-set/single)
362   (:translate %raw-instance-set/single)
363   (:policy :fast-safe)
364   (:args (object :scs (descriptor-reg))
365          (index :scs (any-reg))
366          (value :scs (single-reg) :target result))
367   (:arg-types * positive-fixnum single-float)
368   (:results (result :scs (single-reg)))
369   (:result-types single-float)
370   (:temporary (:scs (non-descriptor-reg)) offset)
371   (:generator 5
372     (loadw offset object 0 instance-pointer-lowtag)
373     (inst srl offset offset n-widetag-bits)
374     (inst sll offset offset 2)
375     (inst sub offset offset index)
376     (inst add
377           offset
378           offset
379           (- (* (1- instance-slots-offset) n-word-bytes)
380              instance-pointer-lowtag))
381     (inst stf value object offset)
382     (unless (location= result value)
383       (inst fmovs result value))))
384
385 (define-vop (raw-instance-ref/double)
386   (:translate %raw-instance-ref/double)
387   (:policy :fast-safe)
388   (:args (object :scs (descriptor-reg))
389          (index :scs (any-reg)))
390   (:arg-types * positive-fixnum)
391   (:results (value :scs (double-reg)))
392   (:temporary (:scs (non-descriptor-reg)) offset)
393   (:result-types double-float)
394   (:generator 5
395     (loadw offset object 0 instance-pointer-lowtag)
396     (inst srl offset offset n-widetag-bits)
397     (inst sll offset offset 2)
398     (inst sub offset offset index)
399     (inst add
400           offset
401           offset
402           (- (* (- instance-slots-offset 2) n-word-bytes)
403              instance-pointer-lowtag))
404     (inst lddf value object offset)))
405
406 (define-vop (raw-instance-set/double)
407   (:translate %raw-instance-set/double)
408   (:policy :fast-safe)
409   (:args (object :scs (descriptor-reg))
410          (index :scs (any-reg))
411          (value :scs (double-reg) :target result))
412   (:arg-types * positive-fixnum double-float)
413   (:results (result :scs (double-reg)))
414   (:result-types double-float)
415   (:temporary (:scs (non-descriptor-reg)) offset)
416   (:generator 5
417     (loadw offset object 0 instance-pointer-lowtag)
418     (inst srl offset offset n-widetag-bits)
419     (inst sll offset offset 2)
420     (inst sub offset offset index)
421     (inst add
422           offset
423           offset
424           (- (* (- instance-slots-offset 2) n-word-bytes)
425              instance-pointer-lowtag))
426     (inst stdf value object offset)
427     (unless (location= result value)
428       (move-double-reg result value))))
429
430 (define-vop (raw-instance-ref/complex-single)
431   (:translate %raw-instance-ref/complex-single)
432   (:policy :fast-safe)
433   (:args (object :scs (descriptor-reg))
434          (index :scs (any-reg)))
435   (:arg-types * positive-fixnum)
436   (:results (value :scs (complex-single-reg)))
437   (:temporary (:scs (non-descriptor-reg)) offset)
438   (:result-types complex-single-float)
439   (:generator 5
440     (loadw offset object 0 instance-pointer-lowtag)
441     (inst srl offset offset n-widetag-bits)
442     (inst sll offset offset 2)
443     (inst sub offset offset index)
444     (inst add
445           offset
446           offset
447           (- (* (- instance-slots-offset 2) n-word-bytes)
448              instance-pointer-lowtag))
449     (inst ldf (complex-single-reg-real-tn value) object offset)
450     (inst add offset offset n-word-bytes)
451     (inst ldf (complex-single-reg-imag-tn value) object offset)))
452
453 (define-vop (raw-instance-set/complex-single)
454   (:translate %raw-instance-set/complex-single)
455   (:policy :fast-safe)
456   (:args (object :scs (descriptor-reg))
457          (index :scs (any-reg))
458          (value :scs (complex-single-reg) :target result))
459   (:arg-types * positive-fixnum complex-single-float)
460   (:results (result :scs (complex-single-reg)))
461   (:result-types complex-single-float)
462   (:temporary (:scs (non-descriptor-reg)) offset)
463   (:generator 5
464     (loadw offset object 0 instance-pointer-lowtag)
465     (inst srl offset offset n-widetag-bits)
466     (inst sll offset offset 2)
467     (inst sub offset offset index)
468     (inst add
469           offset
470           offset
471           (- (* (- instance-slots-offset 2) n-word-bytes)
472              instance-pointer-lowtag))
473     (let ((value-real (complex-single-reg-real-tn value))
474           (result-real (complex-single-reg-real-tn result)))
475       (inst stf value-real object offset)
476       (unless (location= result-real value-real)
477         (inst fmovs result-real value-real)))
478     (inst add offset offset n-word-bytes)
479     (let ((value-imag (complex-single-reg-imag-tn value))
480           (result-imag (complex-single-reg-imag-tn result)))
481       (inst stf value-imag object offset)
482       (unless (location= result-imag value-imag)
483         (inst fmovs result-imag value-imag)))))
484
485 (define-vop (raw-instance-ref/complex-double)
486   (:translate %raw-instance-ref/complex-double)
487   (:policy :fast-safe)
488   (:args (object :scs (descriptor-reg))
489          (index :scs (any-reg)))
490   (:arg-types * positive-fixnum)
491   (:results (value :scs (complex-double-reg)))
492   (:temporary (:scs (non-descriptor-reg)) offset)
493   (:result-types complex-double-float)
494   (:generator 5
495     (loadw offset object 0 instance-pointer-lowtag)
496     (inst srl offset offset n-widetag-bits)
497     (inst sll offset offset 2)
498     (inst sub offset offset index)
499     (inst add
500           offset
501           offset
502           (- (* (- instance-slots-offset 4) n-word-bytes)
503              instance-pointer-lowtag))
504     (inst lddf (complex-double-reg-real-tn value) object offset)
505     (inst add offset offset (* 2 n-word-bytes))
506     (inst lddf (complex-double-reg-imag-tn value) object offset)))
507
508 (define-vop (raw-instance-set/complex-double)
509   (:translate %raw-instance-set/complex-double)
510   (:policy :fast-safe)
511   (:args (object :scs (descriptor-reg))
512          (index :scs (any-reg))
513          (value :scs (complex-double-reg) :target result))
514   (:arg-types * positive-fixnum complex-double-float)
515   (:results (result :scs (complex-double-reg)))
516   (:result-types complex-double-float)
517   (:temporary (:scs (non-descriptor-reg)) offset)
518   (:generator 5
519     (loadw offset object 0 instance-pointer-lowtag)
520     (inst srl offset offset n-widetag-bits)
521     (inst sll offset offset 2)
522     (inst sub offset offset index)
523     (inst add
524           offset
525           offset
526           (- (* (- instance-slots-offset 4) n-word-bytes)
527              instance-pointer-lowtag))
528     (let ((value-real (complex-double-reg-real-tn value))
529           (result-real (complex-double-reg-real-tn result)))
530       (inst stdf value-real object offset)
531       (unless (location= result-real value-real)
532         (move-double-reg result-real value-real)))
533     (inst add offset offset (* 2 n-word-bytes))
534     (let ((value-imag (complex-double-reg-imag-tn value))
535           (result-imag (complex-double-reg-imag-tn result)))
536       (inst stdf value-imag object offset)
537       (unless (location= result-imag value-imag)
538         (move-double-reg result-imag value-imag)))))