Declare types of END and TEST in N{LIST,VECTOR}-SUBSTITUTE-IF[-NOT]*
[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
33 (define-vop (init-slot set-slot))
34 \f
35 ;;;; Symbol hacking VOPs:
36
37 ;;; The compiler likes to be able to directly SET symbols.
38 (define-vop (set cell-set)
39   (:variant symbol-value-slot other-pointer-lowtag))
40
41 ;;; Do a cell ref with an error check for being unbound.
42 (define-vop (checked-cell-ref)
43   (:args (object :scs (descriptor-reg) :target obj-temp))
44   (:results (value :scs (descriptor-reg any-reg)))
45   (:policy :fast-safe)
46   (:vop-var vop)
47   (:save-p :compute-only)
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.
51 ;;; So Symbol-Value of NIL is NIL.
52 (define-vop (symbol-value checked-cell-ref)
53   (:translate symbol-value)
54   (:generator 9
55     (move obj-temp object)
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 cmp value unbound-marker-widetag)
59       (inst b :eq err-lab)
60       (inst nop))))
61
62 ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell
63 ;;; is bound.
64 (define-vop (boundp-frob)
65   (:args (object :scs (descriptor-reg)))
66   (:conditional)
67   (:info target not-p)
68   (:policy :fast-safe)
69   (:temporary (:scs (descriptor-reg)) value))
70
71 (define-vop (boundp boundp-frob)
72   (:translate boundp)
73   (:generator 9
74     (loadw value object symbol-value-slot other-pointer-lowtag)
75     (inst cmp value unbound-marker-widetag)
76     (inst b (if not-p :eq :ne) target)
77     (inst nop)))
78
79 (define-vop (fast-symbol-value cell-ref)
80   (:variant symbol-value-slot other-pointer-lowtag)
81   (:policy :fast)
82   (:translate symbol-value))
83
84 (define-vop (symbol-hash)
85   (:policy :fast-safe)
86   (:translate symbol-hash)
87   (:args (symbol :scs (descriptor-reg)))
88   (:results (res :scs (any-reg)))
89   (:result-types positive-fixnum)
90   (:generator 2
91     ;; The symbol-hash slot of NIL holds NIL because it is also the
92     ;; cdr slot, so we have to strip off the two low bits to make sure
93     ;; it is a fixnum.  The lowtag selection magic that is required to
94     ;; ensure this is explained in the comment in objdef.lisp
95     (loadw res symbol symbol-hash-slot other-pointer-lowtag)
96     (inst andn res res fixnum-tag-mask)))
97
98 ;;; On unithreaded builds these are just copies of the non-global versions.
99 (define-vop (%set-symbol-global-value set))
100 (define-vop (symbol-global-value symbol-value)
101   (:translate symbol-global-value))
102 (define-vop (fast-symbol-global-value fast-symbol-value)
103   (:translate symbol-global-value))
104 \f
105 ;;;; FDEFINITION (fdefn) objects.
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   (:generator 10
116     (move obj-temp object)
117     (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag)
118     (inst cmp value null-tn)
119     (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp)))
120       (inst b :eq err-lab))
121     (inst nop)))
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 cmp type simple-fun-header-widetag)
135       (inst b :eq normal-fn)
136       (inst move lip function)
137       (inst li lip (make-fixup "closure_tramp" :foreign))
138       (emit-label normal-fn)
139       (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
140       (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
141       (move result function))))
142
143 (define-vop (fdefn-makunbound)
144   (:policy :fast-safe)
145   (:translate fdefn-makunbound)
146   (:args (fdefn :scs (descriptor-reg) :target result))
147   (:temporary (:scs (non-descriptor-reg)) temp)
148   (:results (result :scs (descriptor-reg)))
149   (:generator 38
150     (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag)
151     (inst li temp (make-fixup "undefined_tramp" :foreign))
152     (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
153     (move result fdefn)))
154
155
156 \f
157 ;;;; Binding and Unbinding.
158
159 ;;; Establish VAL as a binding for SYMBOL.  Save the old value and the
160 ;;; symbol on the binding stack and stuff the new value into the
161 ;;; 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 add bsp-tn bsp-tn (* 2 n-word-bytes))
169     (storew temp bsp-tn (- binding-value-slot binding-size))
170     (storew symbol bsp-tn (- binding-symbol-slot binding-size))
171     (storew val symbol symbol-value-slot other-pointer-lowtag)))
172
173 (define-vop (unbind)
174   (:temporary (:scs (descriptor-reg)) symbol value)
175   (:generator 0
176     (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
177     (loadw value bsp-tn (- binding-value-slot binding-size))
178     (storew value symbol symbol-value-slot other-pointer-lowtag)
179     (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
180     (storew zero-tn bsp-tn (- binding-value-slot binding-size))
181     (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))))
182
183 (define-vop (unbind-to-here)
184   (:args (arg :scs (descriptor-reg any-reg) :target where))
185   (:temporary (:scs (any-reg) :from (:argument 0)) where)
186   (:temporary (:scs (descriptor-reg)) symbol value)
187   (:generator 0
188     (let ((loop (gen-label))
189           (skip (gen-label))
190           (done (gen-label)))
191       (move where arg)
192       (inst cmp where bsp-tn)
193       (inst b :eq done)
194       (inst nop)
195
196       (emit-label loop)
197       (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
198       (inst cmp symbol)
199       (inst b :eq skip)
200       (loadw value bsp-tn (- binding-value-slot binding-size))
201       (storew value symbol symbol-value-slot other-pointer-lowtag)
202       (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
203
204       (emit-label skip)
205       (storew zero-tn bsp-tn (- binding-value-slot binding-size))
206       (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))
207       (inst cmp where bsp-tn)
208       (inst b :ne loop)
209       (inst nop)
210
211       (emit-label done))))
212 \f
213 ;;;; closure indexing.
214
215 (define-vop (closure-index-ref word-index-ref)
216   (:variant closure-info-offset fun-pointer-lowtag)
217   (:translate %closure-index-ref))
218
219 (define-vop (funcallable-instance-info word-index-ref)
220   (:variant funcallable-instance-info-offset fun-pointer-lowtag)
221   (:translate %funcallable-instance-info))
222
223 (define-vop (set-funcallable-instance-info word-index-set)
224   (:variant funcallable-instance-info-offset fun-pointer-lowtag)
225   (:translate %set-funcallable-instance-info))
226
227 (define-vop (closure-ref slot-ref)
228   (:variant closure-info-offset fun-pointer-lowtag))
229
230 (define-vop (closure-init slot-set)
231   (:variant closure-info-offset fun-pointer-lowtag))
232
233 (define-vop (closure-init-from-fp)
234   (:args (object :scs (descriptor-reg)))
235   (:info offset)
236   (:generator 4
237     (storew cfp-tn object (+ closure-info-offset offset) fun-pointer-lowtag)))
238 \f
239 ;;;; value cell hackery.
240
241 (define-vop (value-cell-ref cell-ref)
242   (:variant value-cell-value-slot other-pointer-lowtag))
243
244 (define-vop (value-cell-set cell-set)
245   (:variant value-cell-value-slot other-pointer-lowtag))
246 \f
247 ;;;; instance hackery:
248
249 (define-vop (instance-length)
250   (:policy :fast-safe)
251   (:translate %instance-length)
252   (:args (struct :scs (descriptor-reg)))
253   (:temporary (:scs (non-descriptor-reg)) temp)
254   (:results (res :scs (unsigned-reg)))
255   (:result-types positive-fixnum)
256   (:generator 4
257     (loadw temp struct 0 instance-pointer-lowtag)
258     (inst srl res temp n-widetag-bits)))
259
260 (define-vop (instance-index-ref word-index-ref)
261   (:policy :fast-safe)
262   (:translate %instance-ref)
263   (:variant instance-slots-offset instance-pointer-lowtag)
264   (:arg-types * positive-fixnum))
265
266 (define-vop (instance-index-set word-index-set)
267   (:policy :fast-safe)
268   (:translate %instance-set)
269   (:variant instance-slots-offset instance-pointer-lowtag)
270   (:arg-types * positive-fixnum *))
271 \f
272 ;;;; Code object frobbing.
273
274 (define-vop (code-header-ref word-index-ref)
275   (:translate code-header-ref)
276   (:policy :fast-safe)
277   (:variant 0 other-pointer-lowtag))
278
279 (define-vop (code-header-set word-index-set)
280   (:translate code-header-set)
281   (:policy :fast-safe)
282   (:variant 0 other-pointer-lowtag))
283
284
285 \f
286 ;;;; raw instance slot accessors
287
288 (define-vop (raw-instance-ref/word)
289   (:translate %raw-instance-ref/word)
290   (:policy :fast-safe)
291   (:args (object :scs (descriptor-reg))
292          (index :scs (any-reg)))
293   (:arg-types * positive-fixnum)
294   (:results (value :scs (unsigned-reg)))
295   (:temporary (:scs (non-descriptor-reg)) offset)
296   (:result-types unsigned-num)
297   (:generator 5
298     (loadw offset object 0 instance-pointer-lowtag)
299     (inst srl offset offset n-widetag-bits)
300     (inst sll offset offset n-fixnum-tag-bits)
301     (inst sub offset offset index)
302     (inst add
303           offset
304           offset
305           (- (* (1- instance-slots-offset) n-word-bytes)
306              instance-pointer-lowtag))
307     (inst ld value object offset)))
308
309 (define-vop (raw-instance-set/word)
310   (:translate %raw-instance-set/word)
311   (:policy :fast-safe)
312   (:args (object :scs (descriptor-reg))
313          (index :scs (any-reg))
314          (value :scs (unsigned-reg)))
315   (:arg-types * positive-fixnum unsigned-num)
316   (:results (result :scs (unsigned-reg)))
317   (:temporary (:scs (non-descriptor-reg)) offset)
318   (:result-types unsigned-num)
319   (:generator 5
320     (loadw offset object 0 instance-pointer-lowtag)
321     (inst srl offset offset n-widetag-bits)
322     (inst sll offset offset n-fixnum-tag-bits)
323     (inst sub offset offset index)
324     (inst add
325           offset
326           offset
327           (- (* (1- instance-slots-offset) n-word-bytes)
328              instance-pointer-lowtag))
329     (inst st value object offset)
330     (move result value)))
331
332 (define-vop (raw-instance-ref/single)
333   (:translate %raw-instance-ref/single)
334   (:policy :fast-safe)
335   (:args (object :scs (descriptor-reg))
336          (index :scs (any-reg)))
337   (:arg-types * positive-fixnum)
338   (:results (value :scs (single-reg)))
339   (:temporary (:scs (non-descriptor-reg)) offset)
340   (:result-types single-float)
341   (:generator 5
342     (loadw offset object 0 instance-pointer-lowtag)
343     (inst srl offset offset n-widetag-bits)
344     (inst sll offset offset n-fixnum-tag-bits)
345     (inst sub offset offset index)
346     (inst add
347           offset
348           offset
349           (- (* (1- instance-slots-offset) n-word-bytes)
350              instance-pointer-lowtag))
351     (inst ldf value object offset)))
352
353 (define-vop (raw-instance-set/single)
354   (:translate %raw-instance-set/single)
355   (:policy :fast-safe)
356   (:args (object :scs (descriptor-reg))
357          (index :scs (any-reg))
358          (value :scs (single-reg) :target result))
359   (:arg-types * positive-fixnum single-float)
360   (:results (result :scs (single-reg)))
361   (:result-types single-float)
362   (:temporary (:scs (non-descriptor-reg)) offset)
363   (:generator 5
364     (loadw offset object 0 instance-pointer-lowtag)
365     (inst srl offset offset n-widetag-bits)
366     (inst sll offset offset n-fixnum-tag-bits)
367     (inst sub offset offset index)
368     (inst add
369           offset
370           offset
371           (- (* (1- instance-slots-offset) n-word-bytes)
372              instance-pointer-lowtag))
373     (inst stf value object offset)
374     (unless (location= result value)
375       (inst fmovs result value))))
376
377 (define-vop (raw-instance-ref/double)
378   (:translate %raw-instance-ref/double)
379   (:policy :fast-safe)
380   (:args (object :scs (descriptor-reg))
381          (index :scs (any-reg)))
382   (:arg-types * positive-fixnum)
383   (:results (value :scs (double-reg)))
384   (:temporary (:scs (non-descriptor-reg)) offset)
385   (:result-types double-float)
386   (:generator 5
387     (loadw offset object 0 instance-pointer-lowtag)
388     (inst srl offset offset n-widetag-bits)
389     (inst sll offset offset n-fixnum-tag-bits)
390     (inst sub offset offset index)
391     (inst add
392           offset
393           offset
394           (- (* (- instance-slots-offset 2) n-word-bytes)
395              instance-pointer-lowtag))
396     (inst lddf value object offset)))
397
398 (define-vop (raw-instance-set/double)
399   (:translate %raw-instance-set/double)
400   (:policy :fast-safe)
401   (:args (object :scs (descriptor-reg))
402          (index :scs (any-reg))
403          (value :scs (double-reg) :target result))
404   (:arg-types * positive-fixnum double-float)
405   (:results (result :scs (double-reg)))
406   (:result-types double-float)
407   (:temporary (:scs (non-descriptor-reg)) offset)
408   (:generator 5
409     (loadw offset object 0 instance-pointer-lowtag)
410     (inst srl offset offset n-widetag-bits)
411     (inst sll offset offset n-fixnum-tag-bits)
412     (inst sub offset offset index)
413     (inst add
414           offset
415           offset
416           (- (* (- instance-slots-offset 2) n-word-bytes)
417              instance-pointer-lowtag))
418     (inst stdf value object offset)
419     (unless (location= result value)
420       (move-double-reg result value))))
421
422 (define-vop (raw-instance-ref/complex-single)
423   (:translate %raw-instance-ref/complex-single)
424   (:policy :fast-safe)
425   (:args (object :scs (descriptor-reg))
426          (index :scs (any-reg)))
427   (:arg-types * positive-fixnum)
428   (:results (value :scs (complex-single-reg)))
429   (:temporary (:scs (non-descriptor-reg)) offset)
430   (:result-types complex-single-float)
431   (:generator 5
432     (loadw offset object 0 instance-pointer-lowtag)
433     (inst srl offset offset n-widetag-bits)
434     (inst sll offset offset n-fixnum-tag-bits)
435     (inst sub offset offset index)
436     (inst add
437           offset
438           offset
439           (- (* (- instance-slots-offset 2) n-word-bytes)
440              instance-pointer-lowtag))
441     (inst ldf (complex-single-reg-real-tn value) object offset)
442     (inst add offset offset n-word-bytes)
443     (inst ldf (complex-single-reg-imag-tn value) object offset)))
444
445 (define-vop (raw-instance-set/complex-single)
446   (:translate %raw-instance-set/complex-single)
447   (:policy :fast-safe)
448   (:args (object :scs (descriptor-reg))
449          (index :scs (any-reg))
450          (value :scs (complex-single-reg) :target result))
451   (:arg-types * positive-fixnum complex-single-float)
452   (:results (result :scs (complex-single-reg)))
453   (:result-types complex-single-float)
454   (:temporary (:scs (non-descriptor-reg)) offset)
455   (:generator 5
456     (loadw offset object 0 instance-pointer-lowtag)
457     (inst srl offset offset n-widetag-bits)
458     (inst sll offset offset n-fixnum-tag-bits)
459     (inst sub offset offset index)
460     (inst add
461           offset
462           offset
463           (- (* (- instance-slots-offset 2) n-word-bytes)
464              instance-pointer-lowtag))
465     (let ((value-real (complex-single-reg-real-tn value))
466           (result-real (complex-single-reg-real-tn result)))
467       (inst stf value-real object offset)
468       (unless (location= result-real value-real)
469         (inst fmovs result-real value-real)))
470     (inst add offset offset n-word-bytes)
471     (let ((value-imag (complex-single-reg-imag-tn value))
472           (result-imag (complex-single-reg-imag-tn result)))
473       (inst stf value-imag object offset)
474       (unless (location= result-imag value-imag)
475         (inst fmovs result-imag value-imag)))))
476
477 (define-vop (raw-instance-ref/complex-double)
478   (:translate %raw-instance-ref/complex-double)
479   (:policy :fast-safe)
480   (:args (object :scs (descriptor-reg))
481          (index :scs (any-reg)))
482   (:arg-types * positive-fixnum)
483   (:results (value :scs (complex-double-reg)))
484   (:temporary (:scs (non-descriptor-reg)) offset)
485   (:result-types complex-double-float)
486   (:generator 5
487     (loadw offset object 0 instance-pointer-lowtag)
488     (inst srl offset offset n-widetag-bits)
489     (inst sll offset offset n-fixnum-tag-bits)
490     (inst sub offset offset index)
491     (inst add
492           offset
493           offset
494           (- (* (- instance-slots-offset 4) n-word-bytes)
495              instance-pointer-lowtag))
496     (inst lddf (complex-double-reg-real-tn value) object offset)
497     (inst add offset offset (* 2 n-word-bytes))
498     (inst lddf (complex-double-reg-imag-tn value) object offset)))
499
500 (define-vop (raw-instance-set/complex-double)
501   (:translate %raw-instance-set/complex-double)
502   (:policy :fast-safe)
503   (:args (object :scs (descriptor-reg))
504          (index :scs (any-reg))
505          (value :scs (complex-double-reg) :target result))
506   (:arg-types * positive-fixnum complex-double-float)
507   (:results (result :scs (complex-double-reg)))
508   (:result-types complex-double-float)
509   (:temporary (:scs (non-descriptor-reg)) offset)
510   (:generator 5
511     (loadw offset object 0 instance-pointer-lowtag)
512     (inst srl offset offset n-widetag-bits)
513     (inst sll offset offset n-fixnum-tag-bits)
514     (inst sub offset offset index)
515     (inst add
516           offset
517           offset
518           (- (* (- instance-slots-offset 4) n-word-bytes)
519              instance-pointer-lowtag))
520     (let ((value-real (complex-double-reg-real-tn value))
521           (result-real (complex-double-reg-real-tn result)))
522       (inst stdf value-real object offset)
523       (unless (location= result-real value-real)
524         (move-double-reg result-real value-real)))
525     (inst add offset offset (* 2 n-word-bytes))
526     (let ((value-imag (complex-double-reg-imag-tn value))
527           (result-imag (complex-double-reg-imag-tn result)))
528       (inst stdf value-imag object offset)
529       (unless (location= result-imag value-imag)
530         (move-double-reg result-imag value-imag)))))