1.0.9.52: copy propagation interfering with local calls
[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-symbol-slot binding-size))
171     (storew zero-tn bsp-tn (- binding-value-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-symbol-slot binding-size))
194
195       (emit-label skip)
196       (storew zero-tn bsp-tn (- binding-value-slot binding-size))
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 (closure-ref slot-ref)
219   (:variant closure-info-offset fun-pointer-lowtag))
220
221 (define-vop (closure-init slot-set)
222   (:variant closure-info-offset fun-pointer-lowtag))
223 \f
224 ;;;; value cell hackery.
225
226 (define-vop (value-cell-ref cell-ref)
227   (:variant value-cell-value-slot other-pointer-lowtag))
228
229 (define-vop (value-cell-set cell-set)
230   (:variant value-cell-value-slot other-pointer-lowtag))
231 \f
232 ;;;; instance hackery:
233
234 (define-vop (instance-length)
235   (:policy :fast-safe)
236   (:translate %instance-length)
237   (:args (struct :scs (descriptor-reg)))
238   (:temporary (:scs (non-descriptor-reg)) temp)
239   (:results (res :scs (unsigned-reg)))
240   (:result-types positive-fixnum)
241   (:generator 4
242     (loadw temp struct 0 instance-pointer-lowtag)
243     (inst srl res temp n-widetag-bits)))
244
245 (define-vop (instance-index-ref word-index-ref)
246   (:policy :fast-safe)
247   (:translate %instance-ref)
248   (:variant instance-slots-offset instance-pointer-lowtag)
249   (:arg-types * positive-fixnum))
250
251 (define-vop (instance-index-set word-index-set)
252   (:policy :fast-safe)
253   (:translate %instance-set)
254   (:variant instance-slots-offset instance-pointer-lowtag)
255   (:arg-types * positive-fixnum *))
256 \f
257 ;;;; Code object frobbing.
258
259 (define-vop (code-header-ref word-index-ref)
260   (:translate code-header-ref)
261   (:policy :fast-safe)
262   (:variant 0 other-pointer-lowtag))
263
264 (define-vop (code-header-set word-index-set)
265   (:translate code-header-set)
266   (:policy :fast-safe)
267   (:variant 0 other-pointer-lowtag))
268
269
270 \f
271 ;;;; raw instance slot accessors
272
273 (define-vop (raw-instance-ref/word)
274   (:translate %raw-instance-ref/word)
275   (:policy :fast-safe)
276   (:args (object :scs (descriptor-reg))
277          (index :scs (any-reg)))
278   (:arg-types * positive-fixnum)
279   (:results (value :scs (unsigned-reg)))
280   (:temporary (:scs (non-descriptor-reg)) offset)
281   (:result-types unsigned-num)
282   (:generator 5
283     (loadw offset object 0 instance-pointer-lowtag)
284     (inst srl offset offset n-widetag-bits)
285     (inst sll offset offset 2)
286     (inst sub offset offset index)
287     (inst add
288           offset
289           offset
290           (- (* (1- instance-slots-offset) n-word-bytes)
291              instance-pointer-lowtag))
292     (inst ld value object offset)))
293
294 (define-vop (raw-instance-set/word)
295   (:translate %raw-instance-set/word)
296   (:policy :fast-safe)
297   (:args (object :scs (descriptor-reg))
298          (index :scs (any-reg))
299          (value :scs (unsigned-reg)))
300   (:arg-types * positive-fixnum unsigned-num)
301   (:results (result :scs (unsigned-reg)))
302   (:temporary (:scs (non-descriptor-reg)) offset)
303   (:result-types unsigned-num)
304   (:generator 5
305     (loadw offset object 0 instance-pointer-lowtag)
306     (inst srl offset offset n-widetag-bits)
307     (inst sll offset offset 2)
308     (inst sub offset offset index)
309     (inst add
310           offset
311           offset
312           (- (* (1- instance-slots-offset) n-word-bytes)
313              instance-pointer-lowtag))
314     (inst st value object offset)
315     (move result value)))
316
317 (define-vop (raw-instance-ref/single)
318   (:translate %raw-instance-ref/single)
319   (:policy :fast-safe)
320   (:args (object :scs (descriptor-reg))
321          (index :scs (any-reg)))
322   (:arg-types * positive-fixnum)
323   (:results (value :scs (single-reg)))
324   (:temporary (:scs (non-descriptor-reg)) offset)
325   (:result-types single-float)
326   (:generator 5
327     (loadw offset object 0 instance-pointer-lowtag)
328     (inst srl offset offset n-widetag-bits)
329     (inst sll offset offset 2)
330     (inst sub offset offset index)
331     (inst add
332           offset
333           offset
334           (- (* (1- instance-slots-offset) n-word-bytes)
335              instance-pointer-lowtag))
336     (inst ldf value object offset)))
337
338 (define-vop (raw-instance-set/single)
339   (:translate %raw-instance-set/single)
340   (:policy :fast-safe)
341   (:args (object :scs (descriptor-reg))
342          (index :scs (any-reg))
343          (value :scs (single-reg) :target result))
344   (:arg-types * positive-fixnum single-float)
345   (:results (result :scs (single-reg)))
346   (:result-types single-float)
347   (:temporary (:scs (non-descriptor-reg)) offset)
348   (:generator 5
349     (loadw offset object 0 instance-pointer-lowtag)
350     (inst srl offset offset n-widetag-bits)
351     (inst sll offset offset 2)
352     (inst sub offset offset index)
353     (inst add
354           offset
355           offset
356           (- (* (1- instance-slots-offset) n-word-bytes)
357              instance-pointer-lowtag))
358     (inst stf value object offset)
359     (unless (location= result value)
360       (inst fmovs result value))))
361
362 (define-vop (raw-instance-ref/double)
363   (:translate %raw-instance-ref/double)
364   (:policy :fast-safe)
365   (:args (object :scs (descriptor-reg))
366          (index :scs (any-reg)))
367   (:arg-types * positive-fixnum)
368   (:results (value :scs (double-reg)))
369   (:temporary (:scs (non-descriptor-reg)) offset)
370   (:result-types double-float)
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           (- (* (- instance-slots-offset 2) n-word-bytes)
380              instance-pointer-lowtag))
381     (inst lddf value object offset)))
382
383 (define-vop (raw-instance-set/double)
384   (:translate %raw-instance-set/double)
385   (:policy :fast-safe)
386   (:args (object :scs (descriptor-reg))
387          (index :scs (any-reg))
388          (value :scs (double-reg) :target result))
389   (:arg-types * positive-fixnum double-float)
390   (:results (result :scs (double-reg)))
391   (:result-types double-float)
392   (:temporary (:scs (non-descriptor-reg)) offset)
393   (:generator 5
394     (loadw offset object 0 instance-pointer-lowtag)
395     (inst srl offset offset n-widetag-bits)
396     (inst sll offset offset 2)
397     (inst sub offset offset index)
398     (inst add
399           offset
400           offset
401           (- (* (- instance-slots-offset 2) n-word-bytes)
402              instance-pointer-lowtag))
403     (inst stdf value object offset)
404     (unless (location= result value)
405       (move-double-reg result value))))
406
407 (define-vop (raw-instance-ref/complex-single)
408   (:translate %raw-instance-ref/complex-single)
409   (:policy :fast-safe)
410   (:args (object :scs (descriptor-reg))
411          (index :scs (any-reg)))
412   (:arg-types * positive-fixnum)
413   (:results (value :scs (complex-single-reg)))
414   (:temporary (:scs (non-descriptor-reg)) offset)
415   (:result-types complex-single-float)
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 ldf (complex-single-reg-real-tn value) object offset)
427     (inst add offset offset n-word-bytes)
428     (inst ldf (complex-single-reg-imag-tn value) object offset)))
429
430 (define-vop (raw-instance-set/complex-single)
431   (:translate %raw-instance-set/complex-single)
432   (:policy :fast-safe)
433   (:args (object :scs (descriptor-reg))
434          (index :scs (any-reg))
435          (value :scs (complex-single-reg) :target result))
436   (:arg-types * positive-fixnum complex-single-float)
437   (:results (result :scs (complex-single-reg)))
438   (:result-types complex-single-float)
439   (:temporary (:scs (non-descriptor-reg)) offset)
440   (:generator 5
441     (loadw offset object 0 instance-pointer-lowtag)
442     (inst srl offset offset n-widetag-bits)
443     (inst sll offset offset 2)
444     (inst sub offset offset index)
445     (inst add
446           offset
447           offset
448           (- (* (- instance-slots-offset 2) n-word-bytes)
449              instance-pointer-lowtag))
450     (let ((value-real (complex-single-reg-real-tn value))
451           (result-real (complex-single-reg-real-tn result)))
452       (inst stf value-real object offset)
453       (unless (location= result-real value-real)
454         (inst fmovs result-real value-real)))
455     (inst add offset offset n-word-bytes)
456     (let ((value-imag (complex-single-reg-imag-tn value))
457           (result-imag (complex-single-reg-imag-tn result)))
458       (inst stf value-imag object offset)
459       (unless (location= result-imag value-imag)
460         (inst fmovs result-imag value-imag)))))
461
462 (define-vop (raw-instance-ref/complex-double)
463   (:translate %raw-instance-ref/complex-double)
464   (:policy :fast-safe)
465   (:args (object :scs (descriptor-reg))
466          (index :scs (any-reg)))
467   (:arg-types * positive-fixnum)
468   (:results (value :scs (complex-double-reg)))
469   (:temporary (:scs (non-descriptor-reg)) offset)
470   (:result-types complex-double-float)
471   (:generator 5
472     (loadw offset object 0 instance-pointer-lowtag)
473     (inst srl offset offset n-widetag-bits)
474     (inst sll offset offset 2)
475     (inst sub offset offset index)
476     (inst add
477           offset
478           offset
479           (- (* (- instance-slots-offset 4) n-word-bytes)
480              instance-pointer-lowtag))
481     (inst lddf (complex-double-reg-real-tn value) object offset)
482     (inst add offset offset (* 2 n-word-bytes))
483     (inst lddf (complex-double-reg-imag-tn value) object offset)))
484
485 (define-vop (raw-instance-set/complex-double)
486   (:translate %raw-instance-set/complex-double)
487   (:policy :fast-safe)
488   (:args (object :scs (descriptor-reg))
489          (index :scs (any-reg))
490          (value :scs (complex-double-reg) :target result))
491   (:arg-types * positive-fixnum complex-double-float)
492   (:results (result :scs (complex-double-reg)))
493   (:result-types complex-double-float)
494   (:temporary (:scs (non-descriptor-reg)) offset)
495   (:generator 5
496     (loadw offset object 0 instance-pointer-lowtag)
497     (inst srl offset offset n-widetag-bits)
498     (inst sll offset offset 2)
499     (inst sub offset offset index)
500     (inst add
501           offset
502           offset
503           (- (* (- instance-slots-offset 4) n-word-bytes)
504              instance-pointer-lowtag))
505     (let ((value-real (complex-double-reg-real-tn value))
506           (result-real (complex-double-reg-real-tn result)))
507       (inst stdf value-real object offset)
508       (unless (location= result-real value-real)
509         (move-double-reg result-real value-real)))
510     (inst add offset offset (* 2 n-word-bytes))
511     (let ((value-imag (complex-double-reg-imag-tn value))
512           (result-imag (complex-double-reg-imag-tn result)))
513       (inst stdf value-imag object offset)
514       (unless (location= result-imag value-imag)
515         (move-double-reg result-imag value-imag)))))