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 #!+compare-and-swap-vops
35 (define-vop (compare-and-swap-slot)
36 (:args (object :scs (descriptor-reg))
37 (old :scs (descriptor-reg any-reg))
38 (new :scs (descriptor-reg any-reg)))
39 (:temporary (:sc non-descriptor-reg) temp)
40 (:info name offset lowtag)
42 (:results (result :scs (descriptor-reg) :from :load))
45 (inst li temp (- (* offset n-word-bytes) lowtag))
47 (inst lwarx result temp object)
48 (inst cmpw result old)
50 (inst stwcx. new temp object)
56 ;;;; Symbol hacking VOPs:
58 #!+compare-and-swap-vops
59 (define-vop (%compare-and-swap-symbol-value)
60 (:translate %compare-and-swap-symbol-value)
61 (:args (symbol :scs (descriptor-reg))
62 (old :scs (descriptor-reg any-reg))
63 (new :scs (descriptor-reg any-reg)))
64 (:temporary (:sc non-descriptor-reg) temp)
65 (:results (result :scs (descriptor-reg any-reg) :from :load))
72 (loadw temp symbol symbol-tls-index-slot other-pointer-lowtag)
73 ;; Thread-local area, no synchronization needed.
74 (inst lwzx result thread-base-tn temp)
75 (inst cmpw result old)
76 (inst bne DONT-STORE-TLS)
77 (inst stwx new thread-base-tn temp)
80 (inst cmpwi result no-tls-value-marker-widetag)
81 (inst bne CHECK-UNBOUND))
83 (inst li temp (- (* symbol-value-slot n-word-bytes)
84 other-pointer-lowtag))
86 (inst lwarx result symbol temp)
87 (inst cmpw result old)
88 (inst bne CHECK-UNBOUND)
89 (inst stwcx. new symbol temp)
94 (inst cmpwi result unbound-marker-widetag)
95 (inst beq (generate-error-code vop 'unbound-symbol-error symbol))))
97 ;;; The compiler likes to be able to directly SET symbols.
98 (define-vop (%set-symbol-global-value cell-set)
99 (:variant symbol-value-slot other-pointer-lowtag))
101 ;;; Do a cell ref with an error check for being unbound.
102 (define-vop (checked-cell-ref)
103 (:args (object :scs (descriptor-reg) :target obj-temp))
104 (:results (value :scs (descriptor-reg any-reg)))
107 (:save-p :compute-only)
108 (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
110 ;;; With SYMBOL-VALUE, we check that the value isn't the trap object.
111 ;;; So SYMBOL-VALUE of NIL is NIL.
112 (define-vop (symbol-global-value checked-cell-ref)
113 (:translate symbol-global-value)
115 (move obj-temp object)
116 (loadw value obj-temp symbol-value-slot other-pointer-lowtag)
117 (let ((err-lab (generate-error-code vop 'unbound-symbol-error obj-temp)))
118 (inst cmpwi value unbound-marker-widetag)
119 (inst beq err-lab))))
121 (define-vop (fast-symbol-global-value cell-ref)
122 (:variant symbol-value-slot other-pointer-lowtag)
124 (:translate symbol-global-value))
129 (:args (symbol :scs (descriptor-reg))
130 (value :scs (descriptor-reg any-reg)))
131 (:temporary (:sc any-reg) tls-slot temp)
133 (loadw tls-slot symbol symbol-tls-index-slot other-pointer-lowtag)
134 (inst lwzx temp thread-base-tn tls-slot)
135 (inst cmpwi temp no-tls-value-marker-widetag)
136 (inst beq GLOBAL-VALUE)
137 (inst stwx value thread-base-tn tls-slot)
140 (storew value symbol symbol-value-slot other-pointer-lowtag)
143 ;; With Symbol-Value, we check that the value isn't the trap object. So
144 ;; Symbol-Value of NIL is NIL.
145 (define-vop (symbol-value)
146 (:translate symbol-value)
148 (:args (object :scs (descriptor-reg) :to (:result 1)))
149 (:results (value :scs (descriptor-reg any-reg)))
151 (:save-p :compute-only)
153 (loadw value object symbol-tls-index-slot other-pointer-lowtag)
154 (inst lwzx value thread-base-tn value)
155 (inst cmpwi value no-tls-value-marker-widetag)
156 (inst bne CHECK-UNBOUND)
157 (loadw value object symbol-value-slot other-pointer-lowtag)
159 (inst cmpwi value unbound-marker-widetag)
160 (inst beq (generate-error-code vop 'unbound-symbol-error object))))
162 (define-vop (fast-symbol-value symbol-value)
163 ;; KLUDGE: not really fast, in fact, because we're going to have to
164 ;; do a full lookup of the thread-local area anyway. But half of
165 ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
166 ;; unbound", which is used in the implementation of COPY-SYMBOL. --
169 (:translate symbol-value)
171 (loadw value object symbol-tls-index-slot other-pointer-lowtag)
172 (inst lwzx value thread-base-tn value)
173 (inst cmpwi value no-tls-value-marker-widetag)
175 (loadw value object symbol-value-slot other-pointer-lowtag)
178 ;;; On unithreaded builds these are just copies of the global versions.
181 (define-vop (symbol-value symbol-global-value)
182 (:translate symbol-value))
183 (define-vop (fast-symbol-value fast-symbol-global-value)
184 (:translate symbol-value))
185 (define-vop (set %set-symbol-global-value)))
187 ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell
189 (define-vop (boundp-frob)
190 (:args (object :scs (descriptor-reg)))
194 (:temporary (:scs (descriptor-reg)) value))
197 (define-vop (boundp boundp-frob)
200 (loadw value object symbol-tls-index-slot other-pointer-lowtag)
201 (inst lwzx value thread-base-tn value)
202 (inst cmpwi value no-tls-value-marker-widetag)
203 (inst bne CHECK-UNBOUND)
204 (loadw value object symbol-value-slot other-pointer-lowtag)
206 (inst cmpwi value unbound-marker-widetag)
207 (inst b? (if not-p :eq :ne) target)))
210 (define-vop (boundp boundp-frob)
213 (loadw value object symbol-value-slot other-pointer-lowtag)
214 (inst cmpwi value unbound-marker-widetag)
215 (inst b? (if not-p :eq :ne) target)))
217 (define-vop (symbol-hash)
219 (:translate symbol-hash)
220 (:args (symbol :scs (descriptor-reg)))
221 (:results (res :scs (any-reg)))
222 (:result-types positive-fixnum)
224 ;; The symbol-hash slot of NIL holds NIL because it is also the
225 ;; cdr slot, so we have to strip off the two low bits to make sure
226 ;; it is a fixnum. The lowtag selection magic that is required to
227 ;; ensure this is explained in the comment in objdef.lisp
228 (loadw res symbol symbol-hash-slot other-pointer-lowtag)
229 (inst clrrwi res res n-fixnum-tag-bits)))
231 ;;;; Fdefinition (fdefn) objects.
233 (define-vop (fdefn-fun cell-ref)
234 (:variant fdefn-fun-slot other-pointer-lowtag))
236 (define-vop (safe-fdefn-fun)
237 (:args (object :scs (descriptor-reg) :target obj-temp))
238 (:results (value :scs (descriptor-reg any-reg)))
240 (:save-p :compute-only)
241 (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
243 (move obj-temp object)
244 (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag)
245 (inst cmpw value null-tn)
246 (let ((err-lab (generate-error-code vop 'undefined-fun-error obj-temp)))
247 (inst beq err-lab))))
249 (define-vop (set-fdefn-fun)
251 (:translate (setf fdefn-fun))
252 (:args (function :scs (descriptor-reg) :target result)
253 (fdefn :scs (descriptor-reg)))
254 (:temporary (:scs (interior-reg)) lip)
255 (:temporary (:scs (non-descriptor-reg)) type)
256 (:results (result :scs (descriptor-reg)))
258 (let ((normal-fn (gen-label)))
259 (load-type type function (- fun-pointer-lowtag))
260 (inst cmpwi type simple-fun-header-widetag)
261 ;;(inst mr lip function)
262 (inst addi lip function
263 (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag))
265 (inst lr lip (make-fixup "closure_tramp" :foreign))
266 (emit-label normal-fn)
267 (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
268 (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
269 (move result function))))
271 (define-vop (fdefn-makunbound)
273 (:translate fdefn-makunbound)
274 (:args (fdefn :scs (descriptor-reg) :target result))
275 (:temporary (:scs (non-descriptor-reg)) temp)
276 (:results (result :scs (descriptor-reg)))
278 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag)
279 (inst lr temp (make-fixup "undefined_tramp" :foreign))
280 (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
281 (move result fdefn)))
285 ;;;; Binding and Unbinding.
287 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
288 ;;; the symbol on the binding stack and stuff the new value into the
293 (:args (val :scs (any-reg descriptor-reg))
294 (symbol :scs (descriptor-reg)))
295 (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
296 (:temporary (:scs (descriptor-reg)) temp tls-index)
298 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
299 (inst cmpwi tls-index 0)
302 ;; No TLS slot allocated, so allocate one.
303 (pseudo-atomic (pa-flag)
304 (without-scheduling ()
306 (inst li temp (+ (static-symbol-offset '*tls-index-lock*)
307 (ash symbol-value-slot word-shift)
308 (- other-pointer-lowtag)))
310 (inst lwarx tls-index null-tn temp)
311 (inst cmpwi tls-index 0)
312 (inst bne OBTAIN-LOCK)
313 (inst stwcx. thread-base-tn null-tn temp)
314 (inst bne OBTAIN-LOCK)
317 ;; Check to see if the TLS index was set while we were waiting.
318 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
319 (inst cmpwi tls-index 0)
320 (inst bne RELEASE-LOCK)
322 (load-symbol-value tls-index *free-tls-index*)
323 ;; FIXME: Check for TLS index overflow.
324 (inst addi tls-index tls-index n-word-bytes)
325 (store-symbol-value tls-index *free-tls-index*)
326 (inst addi tls-index tls-index (- n-word-bytes))
327 (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
329 ;; The sync instruction doesn't need to happen if we branch
330 ;; directly to RELEASE-LOCK as we didn't do any stores in that
334 (inst stwx zero-tn null-tn temp)
336 ;; temp is a boxed register, but we've been storing crap in it.
337 ;; fix it before we leave pseudo-atomic.
341 (inst lwzx temp thread-base-tn tls-index)
342 (inst addi bsp-tn bsp-tn (* 2 n-word-bytes))
343 (storew temp bsp-tn (- binding-value-slot binding-size))
344 (storew symbol bsp-tn (- binding-symbol-slot binding-size))
345 (inst stwx val thread-base-tn tls-index)))
349 (:args (val :scs (any-reg descriptor-reg))
350 (symbol :scs (descriptor-reg)))
351 (:temporary (:scs (descriptor-reg)) temp)
353 (loadw temp symbol symbol-value-slot other-pointer-lowtag)
354 (inst addi bsp-tn bsp-tn (* 2 n-word-bytes))
355 (storew temp bsp-tn (- binding-value-slot binding-size))
356 (storew symbol bsp-tn (- binding-symbol-slot binding-size))
357 (storew val symbol symbol-value-slot other-pointer-lowtag)))
361 (:temporary (:scs (descriptor-reg)) tls-index value)
363 (loadw tls-index bsp-tn (- binding-symbol-slot binding-size))
364 (loadw tls-index tls-index symbol-tls-index-slot other-pointer-lowtag)
365 (loadw value bsp-tn (- binding-value-slot binding-size))
366 (inst stwx value thread-base-tn tls-index)
367 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
368 (storew zero-tn bsp-tn (- binding-value-slot binding-size))
369 (inst subi bsp-tn bsp-tn (* 2 n-word-bytes))))
373 (:temporary (:scs (descriptor-reg)) symbol value)
375 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
376 (loadw value bsp-tn (- binding-value-slot binding-size))
377 (storew value symbol symbol-value-slot other-pointer-lowtag)
378 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
379 (storew zero-tn bsp-tn (- binding-value-slot binding-size))
380 (inst subi bsp-tn bsp-tn (* 2 n-word-bytes))))
383 (define-vop (unbind-to-here)
384 (:args (arg :scs (descriptor-reg any-reg) :target where))
385 (:temporary (:scs (any-reg) :from (:argument 0)) where)
386 (:temporary (:scs (descriptor-reg)) symbol value)
388 (let ((loop (gen-label))
392 (inst cmpw where bsp-tn)
396 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
397 (inst cmpwi symbol 0)
399 (loadw value bsp-tn (- binding-value-slot binding-size))
401 (loadw symbol symbol symbol-tls-index-slot other-pointer-lowtag)
403 (inst stwx value thread-base-tn symbol)
405 (storew value symbol symbol-value-slot other-pointer-lowtag)
406 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
409 (storew zero-tn bsp-tn (- binding-value-slot binding-size))
410 (inst subi bsp-tn bsp-tn (* 2 n-word-bytes))
411 (inst cmpw where bsp-tn)
418 ;;;; Closure indexing.
420 (define-vop (closure-index-ref word-index-ref)
421 (:variant closure-info-offset fun-pointer-lowtag)
422 (:translate %closure-index-ref))
424 (define-vop (funcallable-instance-info word-index-ref)
425 (:variant funcallable-instance-info-offset fun-pointer-lowtag)
426 (:translate %funcallable-instance-info))
428 (define-vop (set-funcallable-instance-info word-index-set)
429 (:variant funcallable-instance-info-offset fun-pointer-lowtag)
430 (:translate %set-funcallable-instance-info))
432 (define-vop (closure-ref slot-ref)
433 (:variant closure-info-offset fun-pointer-lowtag))
435 (define-vop (closure-init slot-set)
436 (:variant closure-info-offset fun-pointer-lowtag))
438 (define-vop (closure-init-from-fp)
439 (:args (object :scs (descriptor-reg)))
442 (storew cfp-tn object (+ closure-info-offset offset) fun-pointer-lowtag)))
444 ;;;; Value Cell hackery.
446 (define-vop (value-cell-ref cell-ref)
447 (:variant value-cell-value-slot other-pointer-lowtag))
449 (define-vop (value-cell-set cell-set)
450 (:variant value-cell-value-slot other-pointer-lowtag))
454 ;;;; Instance hackery:
456 (define-vop (instance-length)
458 (:translate %instance-length)
459 (:args (struct :scs (descriptor-reg)))
460 (:temporary (:scs (non-descriptor-reg)) temp)
461 (:results (res :scs (unsigned-reg)))
462 (:result-types positive-fixnum)
464 (loadw temp struct 0 instance-pointer-lowtag)
465 (inst srwi res temp n-widetag-bits)))
467 (define-vop (instance-index-ref word-index-ref)
469 (:translate %instance-ref)
470 (:variant instance-slots-offset instance-pointer-lowtag)
471 (:arg-types instance positive-fixnum))
473 (define-vop (instance-index-set word-index-set)
475 (:translate %instance-set)
476 (:variant instance-slots-offset instance-pointer-lowtag)
477 (:arg-types instance positive-fixnum *))
479 #!+compare-and-swap-vops
480 (define-vop (%compare-and-swap-instance-ref word-index-cas)
482 (:translate %compare-and-swap-instance-ref)
483 (:variant instance-slots-offset instance-pointer-lowtag)
484 (:arg-types instance tagged-num * *))
487 ;;;; Code object frobbing.
489 (define-vop (code-header-ref word-index-ref)
490 (:translate code-header-ref)
492 (:variant 0 other-pointer-lowtag))
494 (define-vop (code-header-set word-index-set)
495 (:translate code-header-set)
497 (:variant 0 other-pointer-lowtag))
501 ;;;; raw instance slot accessors
503 (defun offset-for-raw-slot (instance-length index n-words)
504 (+ (* (- instance-length instance-slots-offset index (1- n-words))
506 (- instance-pointer-lowtag)))
508 (define-vop (raw-instance-init/word)
509 (:args (object :scs (descriptor-reg))
510 (value :scs (unsigned-reg)))
511 (:arg-types * unsigned-num)
512 (:info instance-length index)
514 (inst stw value object (offset-for-raw-slot instance-length index 1))))
516 (define-vop (raw-instance-atomic-incf/word)
517 (:translate %raw-instance-atomic-incf/word)
519 (:args (object :scs (descriptor-reg))
520 (index :scs (any-reg))
521 (diff :scs (unsigned-reg)))
522 (:arg-types * positive-fixnum unsigned-num)
523 (:temporary (:sc unsigned-reg) offset)
524 (:temporary (:sc non-descriptor-reg) sum)
525 (:results (result :scs (unsigned-reg) :from :load))
526 (:result-types unsigned-num)
528 (loadw offset object 0 instance-pointer-lowtag)
529 ;; offset = (offset >> n-widetag-bits) << 2
530 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
531 (inst subf offset index offset)
535 (- (* (1- instance-slots-offset) n-word-bytes)
536 instance-pointer-lowtag))
537 ;; load the slot value, add DIFF, write the sum back, and return
538 ;; the original slot value, atomically, and include a memory
542 (inst lwarx result offset object)
543 (inst add sum result diff)
544 (inst stwcx. sum offset object)
548 (define-vop (raw-instance-ref/word)
549 (:translate %raw-instance-ref/word)
551 (:args (object :scs (descriptor-reg))
552 (index :scs (any-reg)))
553 (:arg-types * positive-fixnum)
554 (:results (value :scs (unsigned-reg)))
555 (:temporary (:scs (non-descriptor-reg)) offset)
556 (:result-types unsigned-num)
558 (loadw offset object 0 instance-pointer-lowtag)
559 ;; offset = (offset >> n-widetag-bits) << 2
560 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
561 (inst subf offset index offset)
565 (- (* (1- instance-slots-offset) n-word-bytes)
566 instance-pointer-lowtag))
567 (inst lwzx value object offset)))
569 (define-vop (raw-instance-set/word)
570 (:translate %raw-instance-set/word)
572 (:args (object :scs (descriptor-reg))
573 (index :scs (any-reg))
574 (value :scs (unsigned-reg)))
575 (:arg-types * positive-fixnum unsigned-num)
576 (:results (result :scs (unsigned-reg)))
577 (:temporary (:scs (non-descriptor-reg)) offset)
578 (:result-types unsigned-num)
580 (loadw offset object 0 instance-pointer-lowtag)
581 ;; offset = (offset >> n-widetag-bits) << 2
582 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
583 (inst subf offset index offset)
587 (- (* (1- instance-slots-offset) n-word-bytes)
588 instance-pointer-lowtag))
589 (inst stwx value object offset)
590 (move result value)))
592 (define-vop (raw-instance-init/single)
593 (:args (object :scs (descriptor-reg))
594 (value :scs (single-reg)))
595 (:arg-types * single-float)
596 (:info instance-length index)
598 (inst stfs value object (offset-for-raw-slot instance-length index 1))))
600 (define-vop (raw-instance-ref/single)
601 (:translate %raw-instance-ref/single)
603 (:args (object :scs (descriptor-reg))
604 (index :scs (any-reg)))
605 (:arg-types * positive-fixnum)
606 (:results (value :scs (single-reg)))
607 (:temporary (:scs (non-descriptor-reg)) offset)
608 (:result-types single-float)
610 (loadw offset object 0 instance-pointer-lowtag)
611 ;; offset = (offset >> n-widetag-bits) << 2
612 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
613 (inst subf offset index offset)
617 (- (* (1- instance-slots-offset) n-word-bytes)
618 instance-pointer-lowtag))
619 (inst lfsx value object offset)))
621 (define-vop (raw-instance-set/single)
622 (:translate %raw-instance-set/single)
624 (:args (object :scs (descriptor-reg))
625 (index :scs (any-reg))
626 (value :scs (single-reg) :target result))
627 (:arg-types * positive-fixnum single-float)
628 (:results (result :scs (single-reg)))
629 (:result-types single-float)
630 (:temporary (:scs (non-descriptor-reg)) offset)
632 (loadw offset object 0 instance-pointer-lowtag)
633 ;; offset = (offset >> n-widetag-bits) << 2
634 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
635 (inst subf offset index offset)
639 (- (* (1- instance-slots-offset) n-word-bytes)
640 instance-pointer-lowtag))
641 (inst stfsx value object offset)
642 (unless (location= result value)
643 (inst frsp result value))))
645 (define-vop (raw-instance-init/double)
646 (:args (object :scs (descriptor-reg))
647 (value :scs (double-reg)))
648 (:arg-types * double-float)
649 (:info instance-length index)
651 (inst stfd value object (offset-for-raw-slot instance-length index 2))))
653 (define-vop (raw-instance-ref/double)
654 (:translate %raw-instance-ref/double)
656 (:args (object :scs (descriptor-reg))
657 (index :scs (any-reg)))
658 (:arg-types * positive-fixnum)
659 (:results (value :scs (double-reg)))
660 (:temporary (:scs (non-descriptor-reg)) offset)
661 (:result-types double-float)
663 (loadw offset object 0 instance-pointer-lowtag)
664 ;; offset = (offset >> n-widetag-bits) << 2
665 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
666 (inst subf offset index offset)
670 (- (* (- instance-slots-offset 2) n-word-bytes)
671 instance-pointer-lowtag))
672 (inst lfdx value object offset)))
674 (define-vop (raw-instance-set/double)
675 (:translate %raw-instance-set/double)
677 (:args (object :scs (descriptor-reg))
678 (index :scs (any-reg))
679 (value :scs (double-reg) :target result))
680 (:arg-types * positive-fixnum double-float)
681 (:results (result :scs (double-reg)))
682 (:result-types double-float)
683 (:temporary (:scs (non-descriptor-reg)) offset)
685 (loadw offset object 0 instance-pointer-lowtag)
686 ;; offset = (offset >> n-widetag-bits) << 2
687 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
688 (inst subf offset index offset)
692 (- (* (- instance-slots-offset 2) n-word-bytes)
693 instance-pointer-lowtag))
694 (inst stfdx value object offset)
695 (unless (location= result value)
696 (inst fmr result value))))
698 (define-vop (raw-instance-init/complex-single)
699 (:args (object :scs (descriptor-reg))
700 (value :scs (complex-single-reg)))
701 (:arg-types * complex-single-float)
702 (:info instance-length index)
704 (inst stfs (complex-single-reg-real-tn value)
705 object (offset-for-raw-slot instance-length index 2))
706 (inst stfs (complex-single-reg-imag-tn value)
707 object (offset-for-raw-slot instance-length index 1))))
709 (define-vop (raw-instance-ref/complex-single)
710 (:translate %raw-instance-ref/complex-single)
712 (:args (object :scs (descriptor-reg))
713 (index :scs (any-reg)))
714 (:arg-types * positive-fixnum)
715 (:results (value :scs (complex-single-reg)))
716 (:temporary (:scs (non-descriptor-reg)) offset)
717 (:result-types complex-single-float)
719 (loadw offset object 0 instance-pointer-lowtag)
720 ;; offset = (offset >> n-widetag-bits) << 2
721 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
722 (inst subf offset index offset)
726 (- (* (- instance-slots-offset 2) n-word-bytes)
727 instance-pointer-lowtag))
728 (inst lfsx (complex-single-reg-real-tn value) object offset)
729 (inst addi offset offset n-word-bytes)
730 (inst lfsx (complex-single-reg-imag-tn value) object offset)))
732 (define-vop (raw-instance-set/complex-single)
733 (:translate %raw-instance-set/complex-single)
735 (:args (object :scs (descriptor-reg))
736 (index :scs (any-reg))
737 (value :scs (complex-single-reg) :target result))
738 (:arg-types * positive-fixnum complex-single-float)
739 (:results (result :scs (complex-single-reg)))
740 (:result-types complex-single-float)
741 (:temporary (:scs (non-descriptor-reg)) offset)
743 (loadw offset object 0 instance-pointer-lowtag)
744 ;; offset = (offset >> n-widetag-bits) << 2
745 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
746 (inst subf offset index offset)
750 (- (* (- instance-slots-offset 2) n-word-bytes)
751 instance-pointer-lowtag))
752 (let ((value-real (complex-single-reg-real-tn value))
753 (result-real (complex-single-reg-real-tn result)))
754 (inst stfsx value-real object offset)
755 (unless (location= result-real value-real)
756 (inst frsp result-real value-real)))
757 (inst addi offset offset n-word-bytes)
758 (let ((value-imag (complex-single-reg-imag-tn value))
759 (result-imag (complex-single-reg-imag-tn result)))
760 (inst stfsx value-imag object offset)
761 (unless (location= result-imag value-imag)
762 (inst frsp result-imag value-imag)))))
764 (define-vop (raw-instance-init/complex-double)
765 (:args (object :scs (descriptor-reg))
766 (value :scs (complex-double-reg)))
767 (:arg-types * complex-double-float)
768 (:info instance-length index)
770 (inst stfd (complex-single-reg-real-tn value)
771 object (offset-for-raw-slot instance-length index 4))
772 (inst stfd (complex-double-reg-imag-tn value)
773 object (offset-for-raw-slot instance-length index 2))))
775 (define-vop (raw-instance-ref/complex-double)
776 (:translate %raw-instance-ref/complex-double)
778 (:args (object :scs (descriptor-reg))
779 (index :scs (any-reg)))
780 (:arg-types * positive-fixnum)
781 (:results (value :scs (complex-double-reg)))
782 (:temporary (:scs (non-descriptor-reg)) offset)
783 (:result-types complex-double-float)
785 (loadw offset object 0 instance-pointer-lowtag)
786 ;; offset = (offset >> n-widetag-bits) << 2
787 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
788 (inst subf offset index offset)
792 (- (* (- instance-slots-offset 4) n-word-bytes)
793 instance-pointer-lowtag))
794 (inst lfdx (complex-double-reg-real-tn value) object offset)
795 (inst addi offset offset (* 2 n-word-bytes))
796 (inst lfdx (complex-double-reg-imag-tn value) object offset)))
798 (define-vop (raw-instance-set/complex-double)
799 (:translate %raw-instance-set/complex-double)
801 (:args (object :scs (descriptor-reg))
802 (index :scs (any-reg))
803 (value :scs (complex-double-reg) :target result))
804 (:arg-types * positive-fixnum complex-double-float)
805 (:results (result :scs (complex-double-reg)))
806 (:result-types complex-double-float)
807 (:temporary (:scs (non-descriptor-reg)) offset)
809 (loadw offset object 0 instance-pointer-lowtag)
810 ;; offset = (offset >> n-widetag-bits) << 2
811 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
812 (inst subf offset index offset)
816 (- (* (- instance-slots-offset 4) n-word-bytes)
817 instance-pointer-lowtag))
818 (let ((value-real (complex-double-reg-real-tn value))
819 (result-real (complex-double-reg-real-tn result)))
820 (inst stfdx value-real object offset)
821 (unless (location= result-real value-real)
822 (inst fmr result-real value-real)))
823 (inst addi offset offset (* 2 n-word-bytes))
824 (let ((value-imag (complex-double-reg-imag-tn value))
825 (result-imag (complex-double-reg-imag-tn result)))
826 (inst stfdx value-imag object offset)
827 (unless (location= result-imag value-imag)
828 (inst fmr result-imag value-imag)))))