1 ;;;; the VM definition of various primitive memory access VOPs for the
4 ;;;; This software is part of the SBCL system. See the README file for
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.
15 ;;;; Data object ref/set stuff.
18 (:args
(object :scs
(descriptor-reg)))
19 (:info name offset lowtag
)
21 (:results
(result :scs
(descriptor-reg any-reg
)))
23 (loadw result object offset lowtag
)))
25 (define-vop (set-slot)
26 (:args
(object :scs
(descriptor-reg))
27 (value :scs
(descriptor-reg any-reg
)))
28 (:info name offset lowtag
)
32 (storew value object offset lowtag
)))
34 (define-vop (init-slot set-slot
))
36 #!+compare-and-swap-vops
37 (define-vop (compare-and-swap-slot)
38 (:args
(object :scs
(descriptor-reg))
39 (old :scs
(descriptor-reg any-reg
))
40 (new :scs
(descriptor-reg any-reg
)))
41 (:temporary
(:sc non-descriptor-reg
) temp
)
42 (:info name offset lowtag
)
44 (:results
(result :scs
(descriptor-reg) :from
:load
))
47 (inst li temp
(- (* offset n-word-bytes
) lowtag
))
49 (inst lwarx result temp object
)
50 (inst cmpw result old
)
52 (inst stwcx. new temp object
)
58 ;;;; Symbol hacking VOPs:
60 #!+compare-and-swap-vops
61 (define-vop (%compare-and-swap-symbol-value
)
62 (:translate %compare-and-swap-symbol-value
)
63 (:args
(symbol :scs
(descriptor-reg))
64 (old :scs
(descriptor-reg any-reg
))
65 (new :scs
(descriptor-reg any-reg
)))
66 (:temporary
(:sc non-descriptor-reg
) temp
)
67 (:results
(result :scs
(descriptor-reg any-reg
) :from
:load
))
74 (loadw temp symbol symbol-tls-index-slot other-pointer-lowtag
)
75 ;; Thread-local area, no synchronization needed.
76 (inst lwzx result thread-base-tn temp
)
77 (inst cmpw result old
)
78 (inst bne DONT-STORE-TLS
)
79 (inst stwx new thread-base-tn temp
)
82 (inst cmpwi result no-tls-value-marker-widetag
)
83 (inst bne CHECK-UNBOUND
))
85 (inst li temp
(- (* symbol-value-slot n-word-bytes
)
86 other-pointer-lowtag
))
88 (inst lwarx result symbol temp
)
89 (inst cmpw result old
)
90 (inst bne CHECK-UNBOUND
)
91 (inst stwcx. new symbol temp
)
96 (inst cmpwi result unbound-marker-widetag
)
97 (inst beq
(generate-error-code vop
'unbound-symbol-error symbol
))))
99 ;;; The compiler likes to be able to directly SET symbols.
100 (define-vop (%set-symbol-global-value cell-set
)
101 (:variant symbol-value-slot other-pointer-lowtag
))
103 ;;; Do a cell ref with an error check for being unbound.
104 (define-vop (checked-cell-ref)
105 (:args
(object :scs
(descriptor-reg) :target obj-temp
))
106 (:results
(value :scs
(descriptor-reg any-reg
)))
109 (:save-p
:compute-only
)
110 (:temporary
(:scs
(descriptor-reg) :from
(:argument
0)) obj-temp
))
112 ;;; With SYMBOL-VALUE, we check that the value isn't the trap object.
113 ;;; So SYMBOL-VALUE of NIL is NIL.
114 (define-vop (symbol-global-value checked-cell-ref
)
115 (:translate symbol-global-value
)
117 (move obj-temp object
)
118 (loadw value obj-temp symbol-value-slot other-pointer-lowtag
)
119 (let ((err-lab (generate-error-code vop
'unbound-symbol-error obj-temp
)))
120 (inst cmpwi value unbound-marker-widetag
)
121 (inst beq err-lab
))))
123 (define-vop (fast-symbol-global-value cell-ref
)
124 (:variant symbol-value-slot other-pointer-lowtag
)
126 (:translate symbol-global-value
))
131 (:args
(symbol :scs
(descriptor-reg))
132 (value :scs
(descriptor-reg any-reg
)))
133 (:temporary
(:sc any-reg
) tls-slot temp
)
135 (loadw tls-slot symbol symbol-tls-index-slot other-pointer-lowtag
)
136 (inst lwzx temp thread-base-tn tls-slot
)
137 (inst cmpwi temp no-tls-value-marker-widetag
)
138 (inst beq GLOBAL-VALUE
)
139 (inst stwx value thread-base-tn tls-slot
)
142 (storew value symbol symbol-value-slot other-pointer-lowtag
)
145 ;; With Symbol-Value, we check that the value isn't the trap object. So
146 ;; Symbol-Value of NIL is NIL.
147 (define-vop (symbol-value)
148 (:translate symbol-value
)
150 (:args
(object :scs
(descriptor-reg) :to
(:result
1)))
151 (:results
(value :scs
(descriptor-reg any-reg
)))
153 (:save-p
:compute-only
)
155 (loadw value object symbol-tls-index-slot other-pointer-lowtag
)
156 (inst lwzx value thread-base-tn value
)
157 (inst cmpwi value no-tls-value-marker-widetag
)
158 (inst bne CHECK-UNBOUND
)
159 (loadw value object symbol-value-slot other-pointer-lowtag
)
161 (inst cmpwi value unbound-marker-widetag
)
162 (inst beq
(generate-error-code vop
'unbound-symbol-error object
))))
164 (define-vop (fast-symbol-value symbol-value
)
165 ;; KLUDGE: not really fast, in fact, because we're going to have to
166 ;; do a full lookup of the thread-local area anyway. But half of
167 ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
168 ;; unbound", which is used in the implementation of COPY-SYMBOL. --
171 (:translate symbol-value
)
173 (loadw value object symbol-tls-index-slot other-pointer-lowtag
)
174 (inst lwzx value thread-base-tn value
)
175 (inst cmpwi value no-tls-value-marker-widetag
)
177 (loadw value object symbol-value-slot other-pointer-lowtag
)
180 ;;; On unithreaded builds these are just copies of the global versions.
183 (define-vop (symbol-value symbol-global-value
)
184 (:translate symbol-value
))
185 (define-vop (fast-symbol-value fast-symbol-global-value
)
186 (:translate symbol-value
))
187 (define-vop (set %set-symbol-global-value
)))
189 ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell
191 (define-vop (boundp-frob)
192 (:args
(object :scs
(descriptor-reg)))
196 (:temporary
(:scs
(descriptor-reg)) value
))
199 (define-vop (boundp boundp-frob
)
202 (loadw value object symbol-tls-index-slot other-pointer-lowtag
)
203 (inst lwzx value thread-base-tn value
)
204 (inst cmpwi value no-tls-value-marker-widetag
)
205 (inst bne CHECK-UNBOUND
)
206 (loadw value object symbol-value-slot other-pointer-lowtag
)
208 (inst cmpwi value unbound-marker-widetag
)
209 (inst b?
(if not-p
:eq
:ne
) target
)))
212 (define-vop (boundp boundp-frob
)
215 (loadw value object symbol-value-slot other-pointer-lowtag
)
216 (inst cmpwi value unbound-marker-widetag
)
217 (inst b?
(if not-p
:eq
:ne
) target
)))
219 (define-vop (symbol-hash)
221 (:translate symbol-hash
)
222 (:args
(symbol :scs
(descriptor-reg)))
223 (:results
(res :scs
(any-reg)))
224 (:result-types positive-fixnum
)
226 ;; The symbol-hash slot of NIL holds NIL because it is also the
227 ;; cdr slot, so we have to strip off the two low bits to make sure
228 ;; it is a fixnum. The lowtag selection magic that is required to
229 ;; ensure this is explained in the comment in objdef.lisp
230 (loadw res symbol symbol-hash-slot other-pointer-lowtag
)
231 (inst clrrwi res res n-fixnum-tag-bits
)))
233 ;;;; Fdefinition (fdefn) objects.
235 (define-vop (fdefn-fun cell-ref
)
236 (:variant fdefn-fun-slot other-pointer-lowtag
))
238 (define-vop (safe-fdefn-fun)
239 (:args
(object :scs
(descriptor-reg) :target obj-temp
))
240 (:results
(value :scs
(descriptor-reg any-reg
)))
242 (:save-p
:compute-only
)
243 (:temporary
(:scs
(descriptor-reg) :from
(:argument
0)) obj-temp
)
245 (move obj-temp object
)
246 (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag
)
247 (inst cmpw value null-tn
)
248 (let ((err-lab (generate-error-code vop
'undefined-fun-error obj-temp
)))
249 (inst beq err-lab
))))
251 (define-vop (set-fdefn-fun)
253 (:translate
(setf fdefn-fun
))
254 (:args
(function :scs
(descriptor-reg) :target result
)
255 (fdefn :scs
(descriptor-reg)))
256 (:temporary
(:scs
(interior-reg)) lip
)
257 (:temporary
(:scs
(non-descriptor-reg)) type
)
258 (:results
(result :scs
(descriptor-reg)))
260 (let ((normal-fn (gen-label)))
261 (load-type type function
(- fun-pointer-lowtag
))
262 (inst cmpwi type simple-fun-header-widetag
)
263 ;;(inst mr lip function)
264 (inst addi lip function
265 (- (ash simple-fun-code-offset word-shift
) fun-pointer-lowtag
))
267 (inst lr lip
(make-fixup "closure_tramp" :foreign
))
268 (emit-label normal-fn
)
269 (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
270 (storew function fdefn fdefn-fun-slot other-pointer-lowtag
)
271 (move result function
))))
273 (define-vop (fdefn-makunbound)
275 (:translate fdefn-makunbound
)
276 (:args
(fdefn :scs
(descriptor-reg) :target result
))
277 (:temporary
(:scs
(non-descriptor-reg)) temp
)
278 (:results
(result :scs
(descriptor-reg)))
280 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag
)
281 (inst lr temp
(make-fixup "undefined_tramp" :foreign
))
282 (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
283 (move result fdefn
)))
287 ;;;; Binding and Unbinding.
289 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
290 ;;; the symbol on the binding stack and stuff the new value into the
292 ;;; See the "Chapter 9: Specials" of the SBCL Internals Manual.
295 (:args
(val :scs
(any-reg descriptor-reg
))
296 (symbol :scs
(descriptor-reg)))
297 (:temporary
(:sc non-descriptor-reg
:offset nl3-offset
) pa-flag
)
298 (:temporary
(:scs
(descriptor-reg)) temp tls-index
)
300 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag
)
301 (inst cmpwi tls-index
0)
304 ;; No TLS slot allocated, so allocate one.
305 (pseudo-atomic (pa-flag)
306 (without-scheduling ()
308 (inst li temp
(+ (static-symbol-offset '*tls-index-lock
*)
309 (ash symbol-value-slot word-shift
)
310 (- other-pointer-lowtag
)))
312 (inst lwarx tls-index null-tn temp
)
313 (inst cmpwi tls-index
0)
314 (inst bne OBTAIN-LOCK
)
315 (inst stwcx. thread-base-tn null-tn temp
)
316 (inst bne OBTAIN-LOCK
)
319 ;; Check to see if the TLS index was set while we were waiting.
320 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag
)
321 (inst cmpwi tls-index
0)
322 (inst bne RELEASE-LOCK
)
324 (load-symbol-value tls-index
*free-tls-index
*)
325 ;; FIXME: Check for TLS index overflow.
326 (inst addi tls-index tls-index n-word-bytes
)
327 (store-symbol-value tls-index
*free-tls-index
*)
328 (inst addi tls-index tls-index
(- n-word-bytes
))
329 (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag
)
331 ;; The sync instruction doesn't need to happen if we branch
332 ;; directly to RELEASE-LOCK as we didn't do any stores in that
336 (inst stwx zero-tn null-tn temp
)
338 ;; temp is a boxed register, but we've been storing crap in it.
339 ;; fix it before we leave pseudo-atomic.
343 (inst lwzx temp thread-base-tn tls-index
)
344 (inst addi bsp-tn bsp-tn
(* binding-size n-word-bytes
))
345 (storew temp bsp-tn
(- binding-value-slot binding-size
))
346 (storew tls-index bsp-tn
(- binding-symbol-slot binding-size
))
347 (inst stwx val thread-base-tn tls-index
)))
351 (:args
(val :scs
(any-reg descriptor-reg
))
352 (symbol :scs
(descriptor-reg)))
353 (:temporary
(:scs
(descriptor-reg)) temp
)
355 (loadw temp symbol symbol-value-slot other-pointer-lowtag
)
356 (inst addi bsp-tn bsp-tn
(* binding-size n-word-bytes
))
357 (storew temp bsp-tn
(- binding-value-slot binding-size
))
358 (storew symbol bsp-tn
(- binding-symbol-slot binding-size
))
359 (storew val symbol symbol-value-slot other-pointer-lowtag
)))
363 (:temporary
(:scs
(descriptor-reg)) tls-index value
)
365 (loadw tls-index bsp-tn
(- binding-symbol-slot binding-size
))
366 (loadw value bsp-tn
(- binding-value-slot binding-size
))
367 (inst stwx value thread-base-tn tls-index
)
368 (storew zero-tn bsp-tn
(- binding-symbol-slot binding-size
))
369 (storew zero-tn bsp-tn
(- binding-value-slot binding-size
))
370 (inst subi bsp-tn bsp-tn
(* binding-size n-word-bytes
))))
374 (:temporary
(:scs
(descriptor-reg)) symbol value
)
376 (loadw symbol bsp-tn
(- binding-symbol-slot binding-size
))
377 (loadw value bsp-tn
(- binding-value-slot binding-size
))
378 (storew value symbol symbol-value-slot other-pointer-lowtag
)
379 (storew zero-tn bsp-tn
(- binding-symbol-slot binding-size
))
380 (storew zero-tn bsp-tn
(- binding-value-slot binding-size
))
381 (inst subi bsp-tn bsp-tn
(* binding-size n-word-bytes
))))
384 (define-vop (unbind-to-here)
385 (:args
(arg :scs
(descriptor-reg any-reg
) :target where
))
386 (:temporary
(:scs
(any-reg) :from
(:argument
0)) where
)
387 (:temporary
(:scs
(descriptor-reg)) symbol value
)
389 (let ((loop (gen-label))
393 (inst cmpw where bsp-tn
)
397 (loadw symbol bsp-tn
(- binding-symbol-slot binding-size
))
398 (inst cmpwi symbol
0)
400 (loadw value bsp-tn
(- binding-value-slot binding-size
))
402 (inst stwx value thread-base-tn symbol
)
404 (storew value symbol symbol-value-slot other-pointer-lowtag
)
405 (storew zero-tn bsp-tn
(- binding-symbol-slot binding-size
))
408 (storew zero-tn bsp-tn
(- binding-value-slot binding-size
))
409 (inst subi bsp-tn bsp-tn
(* binding-size n-word-bytes
))
410 (inst cmpw where bsp-tn
)
417 ;;;; Closure indexing.
419 (define-vop (closure-index-ref word-index-ref
)
420 (:variant closure-info-offset fun-pointer-lowtag
)
421 (:translate %closure-index-ref
))
423 (define-vop (funcallable-instance-info word-index-ref
)
424 (:variant funcallable-instance-info-offset fun-pointer-lowtag
)
425 (:translate %funcallable-instance-info
))
427 (define-vop (set-funcallable-instance-info word-index-set
)
428 (:variant funcallable-instance-info-offset fun-pointer-lowtag
)
429 (:translate %set-funcallable-instance-info
))
431 (define-vop (closure-ref slot-ref
)
432 (:variant closure-info-offset fun-pointer-lowtag
))
434 (define-vop (closure-init slot-set
)
435 (:variant closure-info-offset fun-pointer-lowtag
))
437 (define-vop (closure-init-from-fp)
438 (:args
(object :scs
(descriptor-reg)))
441 (storew cfp-tn object
(+ closure-info-offset offset
) fun-pointer-lowtag
)))
443 ;;;; Value Cell hackery.
445 (define-vop (value-cell-ref cell-ref
)
446 (:variant value-cell-value-slot other-pointer-lowtag
))
448 (define-vop (value-cell-set cell-set
)
449 (:variant value-cell-value-slot other-pointer-lowtag
))
453 ;;;; Instance hackery:
455 (define-vop (instance-length)
457 (:translate %instance-length
)
458 (:args
(struct :scs
(descriptor-reg)))
459 (:temporary
(:scs
(non-descriptor-reg)) temp
)
460 (:results
(res :scs
(unsigned-reg)))
461 (:result-types positive-fixnum
)
463 (loadw temp struct
0 instance-pointer-lowtag
)
464 (inst srwi res temp n-widetag-bits
)))
466 (define-vop (instance-index-ref word-index-ref
)
468 (:translate %instance-ref
)
469 (:variant instance-slots-offset instance-pointer-lowtag
)
470 (:arg-types instance positive-fixnum
))
472 (define-vop (instance-index-set word-index-set
)
474 (:translate %instance-set
)
475 (:variant instance-slots-offset instance-pointer-lowtag
)
476 (:arg-types instance positive-fixnum
*))
478 #!+compare-and-swap-vops
479 (define-vop (%compare-and-swap-instance-ref word-index-cas
)
481 (:translate %compare-and-swap-instance-ref
)
482 (:variant instance-slots-offset instance-pointer-lowtag
)
483 (:arg-types instance tagged-num
* *))
486 ;;;; Code object frobbing.
488 (define-vop (code-header-ref word-index-ref
)
489 (:translate code-header-ref
)
491 (:variant
0 other-pointer-lowtag
))
493 (define-vop (code-header-set word-index-set
)
494 (:translate code-header-set
)
496 (:variant
0 other-pointer-lowtag
))
500 ;;;; raw instance slot accessors
502 (defun offset-for-raw-slot (instance-length index n-words
)
503 (+ (* (- instance-length instance-slots-offset index
(1- n-words
))
505 (- instance-pointer-lowtag
)))
507 (define-vop (raw-instance-init/word
)
508 (:args
(object :scs
(descriptor-reg))
509 (value :scs
(unsigned-reg)))
510 (:arg-types
* unsigned-num
)
511 (:info instance-length index
)
513 (inst stw value object
(offset-for-raw-slot instance-length index
1))))
515 (define-vop (raw-instance-atomic-incf/word
)
516 (:translate %raw-instance-atomic-incf
/word
)
518 (:args
(object :scs
(descriptor-reg))
519 (index :scs
(any-reg))
520 (diff :scs
(unsigned-reg)))
521 (:arg-types
* positive-fixnum unsigned-num
)
522 (:temporary
(:sc unsigned-reg
) offset
)
523 (:temporary
(:sc non-descriptor-reg
) sum
)
524 (:results
(result :scs
(unsigned-reg) :from
:load
))
525 (:result-types unsigned-num
)
527 (loadw offset object
0 instance-pointer-lowtag
)
528 ;; offset = (offset >> n-widetag-bits) << 2
529 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
530 (inst subf offset index offset
)
534 (- (* (1- instance-slots-offset
) n-word-bytes
)
535 instance-pointer-lowtag
))
536 ;; load the slot value, add DIFF, write the sum back, and return
537 ;; the original slot value, atomically, and include a memory
541 (inst lwarx result offset object
)
542 (inst add sum result diff
)
543 (inst stwcx. sum offset object
)
547 (define-vop (raw-instance-ref/word
)
548 (:translate %raw-instance-ref
/word
)
550 (:args
(object :scs
(descriptor-reg))
551 (index :scs
(any-reg)))
552 (:arg-types
* positive-fixnum
)
553 (:results
(value :scs
(unsigned-reg)))
554 (:temporary
(:scs
(non-descriptor-reg)) offset
)
555 (:result-types unsigned-num
)
557 (loadw offset object
0 instance-pointer-lowtag
)
558 ;; offset = (offset >> n-widetag-bits) << 2
559 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
560 (inst subf offset index offset
)
564 (- (* (1- instance-slots-offset
) n-word-bytes
)
565 instance-pointer-lowtag
))
566 (inst lwzx value object offset
)))
568 (define-vop (raw-instance-set/word
)
569 (:translate %raw-instance-set
/word
)
571 (:args
(object :scs
(descriptor-reg))
572 (index :scs
(any-reg))
573 (value :scs
(unsigned-reg)))
574 (:arg-types
* positive-fixnum unsigned-num
)
575 (:results
(result :scs
(unsigned-reg)))
576 (:temporary
(:scs
(non-descriptor-reg)) offset
)
577 (:result-types unsigned-num
)
579 (loadw offset object
0 instance-pointer-lowtag
)
580 ;; offset = (offset >> n-widetag-bits) << 2
581 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
582 (inst subf offset index offset
)
586 (- (* (1- instance-slots-offset
) n-word-bytes
)
587 instance-pointer-lowtag
))
588 (inst stwx value object offset
)
589 (move result value
)))
591 (define-vop (raw-instance-init/single
)
592 (:args
(object :scs
(descriptor-reg))
593 (value :scs
(single-reg)))
594 (:arg-types
* single-float
)
595 (:info instance-length index
)
597 (inst stfs value object
(offset-for-raw-slot instance-length index
1))))
599 (define-vop (raw-instance-ref/single
)
600 (:translate %raw-instance-ref
/single
)
602 (:args
(object :scs
(descriptor-reg))
603 (index :scs
(any-reg)))
604 (:arg-types
* positive-fixnum
)
605 (:results
(value :scs
(single-reg)))
606 (:temporary
(:scs
(non-descriptor-reg)) offset
)
607 (:result-types single-float
)
609 (loadw offset object
0 instance-pointer-lowtag
)
610 ;; offset = (offset >> n-widetag-bits) << 2
611 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
612 (inst subf offset index offset
)
616 (- (* (1- instance-slots-offset
) n-word-bytes
)
617 instance-pointer-lowtag
))
618 (inst lfsx value object offset
)))
620 (define-vop (raw-instance-set/single
)
621 (:translate %raw-instance-set
/single
)
623 (:args
(object :scs
(descriptor-reg))
624 (index :scs
(any-reg))
625 (value :scs
(single-reg) :target result
))
626 (:arg-types
* positive-fixnum single-float
)
627 (:results
(result :scs
(single-reg)))
628 (:result-types single-float
)
629 (:temporary
(:scs
(non-descriptor-reg)) offset
)
631 (loadw offset object
0 instance-pointer-lowtag
)
632 ;; offset = (offset >> n-widetag-bits) << 2
633 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
634 (inst subf offset index offset
)
638 (- (* (1- instance-slots-offset
) n-word-bytes
)
639 instance-pointer-lowtag
))
640 (inst stfsx value object offset
)
641 (unless (location= result value
)
642 (inst frsp result value
))))
644 (define-vop (raw-instance-init/double
)
645 (:args
(object :scs
(descriptor-reg))
646 (value :scs
(double-reg)))
647 (:arg-types
* double-float
)
648 (:info instance-length index
)
650 (inst stfd value object
(offset-for-raw-slot instance-length index
2))))
652 (define-vop (raw-instance-ref/double
)
653 (:translate %raw-instance-ref
/double
)
655 (:args
(object :scs
(descriptor-reg))
656 (index :scs
(any-reg)))
657 (:arg-types
* positive-fixnum
)
658 (:results
(value :scs
(double-reg)))
659 (:temporary
(:scs
(non-descriptor-reg)) offset
)
660 (:result-types double-float
)
662 (loadw offset object
0 instance-pointer-lowtag
)
663 ;; offset = (offset >> n-widetag-bits) << 2
664 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
665 (inst subf offset index offset
)
669 (- (* (- instance-slots-offset
2) n-word-bytes
)
670 instance-pointer-lowtag
))
671 (inst lfdx value object offset
)))
673 (define-vop (raw-instance-set/double
)
674 (:translate %raw-instance-set
/double
)
676 (:args
(object :scs
(descriptor-reg))
677 (index :scs
(any-reg))
678 (value :scs
(double-reg) :target result
))
679 (:arg-types
* positive-fixnum double-float
)
680 (:results
(result :scs
(double-reg)))
681 (:result-types double-float
)
682 (:temporary
(:scs
(non-descriptor-reg)) offset
)
684 (loadw offset object
0 instance-pointer-lowtag
)
685 ;; offset = (offset >> n-widetag-bits) << 2
686 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
687 (inst subf offset index offset
)
691 (- (* (- instance-slots-offset
2) n-word-bytes
)
692 instance-pointer-lowtag
))
693 (inst stfdx value object offset
)
694 (unless (location= result value
)
695 (inst fmr result value
))))
697 (define-vop (raw-instance-init/complex-single
)
698 (:args
(object :scs
(descriptor-reg))
699 (value :scs
(complex-single-reg)))
700 (:arg-types
* complex-single-float
)
701 (:info instance-length index
)
703 (inst stfs
(complex-single-reg-real-tn value
)
704 object
(offset-for-raw-slot instance-length index
2))
705 (inst stfs
(complex-single-reg-imag-tn value
)
706 object
(offset-for-raw-slot instance-length index
1))))
708 (define-vop (raw-instance-ref/complex-single
)
709 (:translate %raw-instance-ref
/complex-single
)
711 (:args
(object :scs
(descriptor-reg))
712 (index :scs
(any-reg)))
713 (:arg-types
* positive-fixnum
)
714 (:results
(value :scs
(complex-single-reg)))
715 (:temporary
(:scs
(non-descriptor-reg)) offset
)
716 (:result-types complex-single-float
)
718 (loadw offset object
0 instance-pointer-lowtag
)
719 ;; offset = (offset >> n-widetag-bits) << 2
720 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
721 (inst subf offset index offset
)
725 (- (* (- instance-slots-offset
2) n-word-bytes
)
726 instance-pointer-lowtag
))
727 (inst lfsx
(complex-single-reg-real-tn value
) object offset
)
728 (inst addi offset offset n-word-bytes
)
729 (inst lfsx
(complex-single-reg-imag-tn value
) object offset
)))
731 (define-vop (raw-instance-set/complex-single
)
732 (:translate %raw-instance-set
/complex-single
)
734 (:args
(object :scs
(descriptor-reg))
735 (index :scs
(any-reg))
736 (value :scs
(complex-single-reg) :target result
))
737 (:arg-types
* positive-fixnum complex-single-float
)
738 (:results
(result :scs
(complex-single-reg)))
739 (:result-types complex-single-float
)
740 (:temporary
(:scs
(non-descriptor-reg)) offset
)
742 (loadw offset object
0 instance-pointer-lowtag
)
743 ;; offset = (offset >> n-widetag-bits) << 2
744 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
745 (inst subf offset index offset
)
749 (- (* (- instance-slots-offset
2) n-word-bytes
)
750 instance-pointer-lowtag
))
751 (let ((value-real (complex-single-reg-real-tn value
))
752 (result-real (complex-single-reg-real-tn result
)))
753 (inst stfsx value-real object offset
)
754 (unless (location= result-real value-real
)
755 (inst frsp result-real value-real
)))
756 (inst addi offset offset n-word-bytes
)
757 (let ((value-imag (complex-single-reg-imag-tn value
))
758 (result-imag (complex-single-reg-imag-tn result
)))
759 (inst stfsx value-imag object offset
)
760 (unless (location= result-imag value-imag
)
761 (inst frsp result-imag value-imag
)))))
763 (define-vop (raw-instance-init/complex-double
)
764 (:args
(object :scs
(descriptor-reg))
765 (value :scs
(complex-double-reg)))
766 (:arg-types
* complex-double-float
)
767 (:info instance-length index
)
769 (inst stfd
(complex-single-reg-real-tn value
)
770 object
(offset-for-raw-slot instance-length index
4))
771 (inst stfd
(complex-double-reg-imag-tn value
)
772 object
(offset-for-raw-slot instance-length index
2))))
774 (define-vop (raw-instance-ref/complex-double
)
775 (:translate %raw-instance-ref
/complex-double
)
777 (:args
(object :scs
(descriptor-reg))
778 (index :scs
(any-reg)))
779 (:arg-types
* positive-fixnum
)
780 (:results
(value :scs
(complex-double-reg)))
781 (:temporary
(:scs
(non-descriptor-reg)) offset
)
782 (:result-types complex-double-float
)
784 (loadw offset object
0 instance-pointer-lowtag
)
785 ;; offset = (offset >> n-widetag-bits) << 2
786 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
787 (inst subf offset index offset
)
791 (- (* (- instance-slots-offset
4) n-word-bytes
)
792 instance-pointer-lowtag
))
793 (inst lfdx
(complex-double-reg-real-tn value
) object offset
)
794 (inst addi offset offset
(* 2 n-word-bytes
))
795 (inst lfdx
(complex-double-reg-imag-tn value
) object offset
)))
797 (define-vop (raw-instance-set/complex-double
)
798 (:translate %raw-instance-set
/complex-double
)
800 (:args
(object :scs
(descriptor-reg))
801 (index :scs
(any-reg))
802 (value :scs
(complex-double-reg) :target result
))
803 (:arg-types
* positive-fixnum complex-double-float
)
804 (:results
(result :scs
(complex-double-reg)))
805 (:result-types complex-double-float
)
806 (:temporary
(:scs
(non-descriptor-reg)) offset
)
808 (loadw offset object
0 instance-pointer-lowtag
)
809 ;; offset = (offset >> n-widetag-bits) << 2
810 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
811 (inst subf offset index offset
)
815 (- (* (- instance-slots-offset
4) n-word-bytes
)
816 instance-pointer-lowtag
))
817 (let ((value-real (complex-double-reg-real-tn value
))
818 (result-real (complex-double-reg-real-tn result
)))
819 (inst stfdx value-real object offset
)
820 (unless (location= result-real value-real
)
821 (inst fmr result-real value-real
)))
822 (inst addi offset offset
(* 2 n-word-bytes
))
823 (let ((value-imag (complex-double-reg-imag-tn value
))
824 (result-imag (complex-double-reg-imag-tn result
)))
825 (inst stfdx value-imag object offset
)
826 (unless (location= result-imag value-imag
)
827 (inst fmr result-imag value-imag
)))))