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))
439 ;;;; Value Cell hackery.
441 (define-vop (value-cell-ref cell-ref)
442 (:variant value-cell-value-slot other-pointer-lowtag))
444 (define-vop (value-cell-set cell-set)
445 (:variant value-cell-value-slot other-pointer-lowtag))
449 ;;;; Instance hackery:
451 (define-vop (instance-length)
453 (:translate %instance-length)
454 (:args (struct :scs (descriptor-reg)))
455 (:temporary (:scs (non-descriptor-reg)) temp)
456 (:results (res :scs (unsigned-reg)))
457 (:result-types positive-fixnum)
459 (loadw temp struct 0 instance-pointer-lowtag)
460 (inst srwi res temp n-widetag-bits)))
462 (define-vop (instance-index-ref word-index-ref)
464 (:translate %instance-ref)
465 (:variant instance-slots-offset instance-pointer-lowtag)
466 (:arg-types instance positive-fixnum))
468 (define-vop (instance-index-set word-index-set)
470 (:translate %instance-set)
471 (:variant instance-slots-offset instance-pointer-lowtag)
472 (:arg-types instance positive-fixnum *))
474 #!+compare-and-swap-vops
475 (define-vop (%compare-and-swap-instance-ref word-index-cas)
477 (:translate %compare-and-swap-instance-ref)
478 (:variant instance-slots-offset instance-pointer-lowtag)
479 (:arg-types instance tagged-num * *))
482 ;;;; Code object frobbing.
484 (define-vop (code-header-ref word-index-ref)
485 (:translate code-header-ref)
487 (:variant 0 other-pointer-lowtag))
489 (define-vop (code-header-set word-index-set)
490 (:translate code-header-set)
492 (:variant 0 other-pointer-lowtag))
496 ;;;; raw instance slot accessors
498 (defun offset-for-raw-slot (instance-length index n-words)
499 (+ (* (- instance-length instance-slots-offset index (1- n-words))
501 (- instance-pointer-lowtag)))
503 (define-vop (raw-instance-init/word)
504 (:args (object :scs (descriptor-reg))
505 (value :scs (unsigned-reg)))
506 (:arg-types * unsigned-num)
507 (:info instance-length index)
509 (inst stw value object (offset-for-raw-slot instance-length index 1))))
511 (define-vop (raw-instance-atomic-incf/word)
512 (:translate %raw-instance-atomic-incf/word)
514 (:args (object :scs (descriptor-reg))
515 (index :scs (any-reg))
516 (diff :scs (unsigned-reg)))
517 (:arg-types * positive-fixnum unsigned-num)
518 (:temporary (:sc unsigned-reg) offset)
519 (:temporary (:sc non-descriptor-reg) sum)
520 (:results (result :scs (unsigned-reg) :from :load))
521 (:result-types unsigned-num)
523 (loadw offset object 0 instance-pointer-lowtag)
524 ;; offset = (offset >> n-widetag-bits) << 2
525 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
526 (inst subf offset index offset)
530 (- (* (1- instance-slots-offset) n-word-bytes)
531 instance-pointer-lowtag))
532 ;; load the slot value, add DIFF, write the sum back, and return
533 ;; the original slot value, atomically, and include a memory
537 (inst lwarx result offset object)
538 (inst add sum result diff)
539 (inst stwcx. sum offset object)
543 (define-vop (raw-instance-ref/word)
544 (:translate %raw-instance-ref/word)
546 (:args (object :scs (descriptor-reg))
547 (index :scs (any-reg)))
548 (:arg-types * positive-fixnum)
549 (:results (value :scs (unsigned-reg)))
550 (:temporary (:scs (non-descriptor-reg)) offset)
551 (:result-types unsigned-num)
553 (loadw offset object 0 instance-pointer-lowtag)
554 ;; offset = (offset >> n-widetag-bits) << 2
555 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
556 (inst subf offset index offset)
560 (- (* (1- instance-slots-offset) n-word-bytes)
561 instance-pointer-lowtag))
562 (inst lwzx value object offset)))
564 (define-vop (raw-instance-set/word)
565 (:translate %raw-instance-set/word)
567 (:args (object :scs (descriptor-reg))
568 (index :scs (any-reg))
569 (value :scs (unsigned-reg)))
570 (:arg-types * positive-fixnum unsigned-num)
571 (:results (result :scs (unsigned-reg)))
572 (:temporary (:scs (non-descriptor-reg)) offset)
573 (:result-types unsigned-num)
575 (loadw offset object 0 instance-pointer-lowtag)
576 ;; offset = (offset >> n-widetag-bits) << 2
577 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
578 (inst subf offset index offset)
582 (- (* (1- instance-slots-offset) n-word-bytes)
583 instance-pointer-lowtag))
584 (inst stwx value object offset)
585 (move result value)))
587 (define-vop (raw-instance-init/single)
588 (:args (object :scs (descriptor-reg))
589 (value :scs (single-reg)))
590 (:arg-types * single-float)
591 (:info instance-length index)
593 (inst stfs value object (offset-for-raw-slot instance-length index 1))))
595 (define-vop (raw-instance-ref/single)
596 (:translate %raw-instance-ref/single)
598 (:args (object :scs (descriptor-reg))
599 (index :scs (any-reg)))
600 (:arg-types * positive-fixnum)
601 (:results (value :scs (single-reg)))
602 (:temporary (:scs (non-descriptor-reg)) offset)
603 (:result-types single-float)
605 (loadw offset object 0 instance-pointer-lowtag)
606 ;; offset = (offset >> n-widetag-bits) << 2
607 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
608 (inst subf offset index offset)
612 (- (* (1- instance-slots-offset) n-word-bytes)
613 instance-pointer-lowtag))
614 (inst lfsx value object offset)))
616 (define-vop (raw-instance-set/single)
617 (:translate %raw-instance-set/single)
619 (:args (object :scs (descriptor-reg))
620 (index :scs (any-reg))
621 (value :scs (single-reg) :target result))
622 (:arg-types * positive-fixnum single-float)
623 (:results (result :scs (single-reg)))
624 (:result-types single-float)
625 (:temporary (:scs (non-descriptor-reg)) offset)
627 (loadw offset object 0 instance-pointer-lowtag)
628 ;; offset = (offset >> n-widetag-bits) << 2
629 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
630 (inst subf offset index offset)
634 (- (* (1- instance-slots-offset) n-word-bytes)
635 instance-pointer-lowtag))
636 (inst stfsx value object offset)
637 (unless (location= result value)
638 (inst frsp result value))))
640 (define-vop (raw-instance-init/double)
641 (:args (object :scs (descriptor-reg))
642 (value :scs (double-reg)))
643 (:arg-types * double-float)
644 (:info instance-length index)
646 (inst stfd value object (offset-for-raw-slot instance-length index 2))))
648 (define-vop (raw-instance-ref/double)
649 (:translate %raw-instance-ref/double)
651 (:args (object :scs (descriptor-reg))
652 (index :scs (any-reg)))
653 (:arg-types * positive-fixnum)
654 (:results (value :scs (double-reg)))
655 (:temporary (:scs (non-descriptor-reg)) offset)
656 (:result-types double-float)
658 (loadw offset object 0 instance-pointer-lowtag)
659 ;; offset = (offset >> n-widetag-bits) << 2
660 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
661 (inst subf offset index offset)
665 (- (* (- instance-slots-offset 2) n-word-bytes)
666 instance-pointer-lowtag))
667 (inst lfdx value object offset)))
669 (define-vop (raw-instance-set/double)
670 (:translate %raw-instance-set/double)
672 (:args (object :scs (descriptor-reg))
673 (index :scs (any-reg))
674 (value :scs (double-reg) :target result))
675 (:arg-types * positive-fixnum double-float)
676 (:results (result :scs (double-reg)))
677 (:result-types double-float)
678 (:temporary (:scs (non-descriptor-reg)) offset)
680 (loadw offset object 0 instance-pointer-lowtag)
681 ;; offset = (offset >> n-widetag-bits) << 2
682 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
683 (inst subf offset index offset)
687 (- (* (- instance-slots-offset 2) n-word-bytes)
688 instance-pointer-lowtag))
689 (inst stfdx value object offset)
690 (unless (location= result value)
691 (inst fmr result value))))
693 (define-vop (raw-instance-init/complex-single)
694 (:args (object :scs (descriptor-reg))
695 (value :scs (complex-single-reg)))
696 (:arg-types * complex-single-float)
697 (:info instance-length index)
699 (inst stfs (complex-single-reg-real-tn value)
700 object (offset-for-raw-slot instance-length index 2))
701 (inst stfs (complex-single-reg-imag-tn value)
702 object (offset-for-raw-slot instance-length index 1))))
704 (define-vop (raw-instance-ref/complex-single)
705 (:translate %raw-instance-ref/complex-single)
707 (:args (object :scs (descriptor-reg))
708 (index :scs (any-reg)))
709 (:arg-types * positive-fixnum)
710 (:results (value :scs (complex-single-reg)))
711 (:temporary (:scs (non-descriptor-reg)) offset)
712 (:result-types complex-single-float)
714 (loadw offset object 0 instance-pointer-lowtag)
715 ;; offset = (offset >> n-widetag-bits) << 2
716 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
717 (inst subf offset index offset)
721 (- (* (- instance-slots-offset 2) n-word-bytes)
722 instance-pointer-lowtag))
723 (inst lfsx (complex-single-reg-real-tn value) object offset)
724 (inst addi offset offset n-word-bytes)
725 (inst lfsx (complex-single-reg-imag-tn value) object offset)))
727 (define-vop (raw-instance-set/complex-single)
728 (:translate %raw-instance-set/complex-single)
730 (:args (object :scs (descriptor-reg))
731 (index :scs (any-reg))
732 (value :scs (complex-single-reg) :target result))
733 (:arg-types * positive-fixnum complex-single-float)
734 (:results (result :scs (complex-single-reg)))
735 (:result-types complex-single-float)
736 (:temporary (:scs (non-descriptor-reg)) offset)
738 (loadw offset object 0 instance-pointer-lowtag)
739 ;; offset = (offset >> n-widetag-bits) << 2
740 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
741 (inst subf offset index offset)
745 (- (* (- instance-slots-offset 2) n-word-bytes)
746 instance-pointer-lowtag))
747 (let ((value-real (complex-single-reg-real-tn value))
748 (result-real (complex-single-reg-real-tn result)))
749 (inst stfsx value-real object offset)
750 (unless (location= result-real value-real)
751 (inst frsp result-real value-real)))
752 (inst addi offset offset n-word-bytes)
753 (let ((value-imag (complex-single-reg-imag-tn value))
754 (result-imag (complex-single-reg-imag-tn result)))
755 (inst stfsx value-imag object offset)
756 (unless (location= result-imag value-imag)
757 (inst frsp result-imag value-imag)))))
759 (define-vop (raw-instance-init/complex-double)
760 (:args (object :scs (descriptor-reg))
761 (value :scs (complex-double-reg)))
762 (:arg-types * complex-double-float)
763 (:info instance-length index)
765 (inst stfd (complex-single-reg-real-tn value)
766 object (offset-for-raw-slot instance-length index 4))
767 (inst stfd (complex-double-reg-imag-tn value)
768 object (offset-for-raw-slot instance-length index 2))))
770 (define-vop (raw-instance-ref/complex-double)
771 (:translate %raw-instance-ref/complex-double)
773 (:args (object :scs (descriptor-reg))
774 (index :scs (any-reg)))
775 (:arg-types * positive-fixnum)
776 (:results (value :scs (complex-double-reg)))
777 (:temporary (:scs (non-descriptor-reg)) offset)
778 (:result-types complex-double-float)
780 (loadw offset object 0 instance-pointer-lowtag)
781 ;; offset = (offset >> n-widetag-bits) << 2
782 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
783 (inst subf offset index offset)
787 (- (* (- instance-slots-offset 4) n-word-bytes)
788 instance-pointer-lowtag))
789 (inst lfdx (complex-double-reg-real-tn value) object offset)
790 (inst addi offset offset (* 2 n-word-bytes))
791 (inst lfdx (complex-double-reg-imag-tn value) object offset)))
793 (define-vop (raw-instance-set/complex-double)
794 (:translate %raw-instance-set/complex-double)
796 (:args (object :scs (descriptor-reg))
797 (index :scs (any-reg))
798 (value :scs (complex-double-reg) :target result))
799 (:arg-types * positive-fixnum complex-double-float)
800 (:results (result :scs (complex-double-reg)))
801 (:result-types complex-double-float)
802 (:temporary (:scs (non-descriptor-reg)) offset)
804 (loadw offset object 0 instance-pointer-lowtag)
805 ;; offset = (offset >> n-widetag-bits) << 2
806 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
807 (inst subf offset index offset)
811 (- (* (- instance-slots-offset 4) n-word-bytes)
812 instance-pointer-lowtag))
813 (let ((value-real (complex-double-reg-real-tn value))
814 (result-real (complex-double-reg-real-tn result)))
815 (inst stfdx value-real object offset)
816 (unless (location= result-real value-real)
817 (inst fmr result-real value-real)))
818 (inst addi offset offset (* 2 n-word-bytes))
819 (let ((value-imag (complex-double-reg-imag-tn value))
820 (result-imag (complex-double-reg-imag-tn result)))
821 (inst stfdx value-imag object offset)
822 (unless (location= result-imag value-imag)
823 (inst fmr result-imag value-imag)))))