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
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
(* 2 n-word-bytes
))
345 (storew temp bsp-tn
(- binding-value-slot binding-size
))
346 (storew symbol 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
(* 2 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 tls-index tls-index symbol-tls-index-slot other-pointer-lowtag
)
367 (loadw value bsp-tn
(- binding-value-slot binding-size
))
368 (inst stwx value thread-base-tn tls-index
)
369 (storew zero-tn bsp-tn
(- binding-symbol-slot binding-size
))
370 (storew zero-tn bsp-tn
(- binding-value-slot binding-size
))
371 (inst subi bsp-tn bsp-tn
(* 2 n-word-bytes
))))
375 (:temporary
(:scs
(descriptor-reg)) symbol value
)
377 (loadw symbol bsp-tn
(- binding-symbol-slot binding-size
))
378 (loadw value bsp-tn
(- binding-value-slot binding-size
))
379 (storew value symbol symbol-value-slot other-pointer-lowtag
)
380 (storew zero-tn bsp-tn
(- binding-symbol-slot binding-size
))
381 (storew zero-tn bsp-tn
(- binding-value-slot binding-size
))
382 (inst subi bsp-tn bsp-tn
(* 2 n-word-bytes
))))
385 (define-vop (unbind-to-here)
386 (:args
(arg :scs
(descriptor-reg any-reg
) :target where
))
387 (:temporary
(:scs
(any-reg) :from
(:argument
0)) where
)
388 (:temporary
(:scs
(descriptor-reg)) symbol value
)
390 (let ((loop (gen-label))
394 (inst cmpw where bsp-tn
)
398 (loadw symbol bsp-tn
(- binding-symbol-slot binding-size
))
399 (inst cmpwi symbol
0)
401 (loadw value bsp-tn
(- binding-value-slot binding-size
))
403 (loadw symbol symbol symbol-tls-index-slot other-pointer-lowtag
)
405 (inst stwx value thread-base-tn symbol
)
407 (storew value symbol symbol-value-slot other-pointer-lowtag
)
408 (storew zero-tn bsp-tn
(- binding-symbol-slot binding-size
))
411 (storew zero-tn bsp-tn
(- binding-value-slot binding-size
))
412 (inst subi bsp-tn bsp-tn
(* 2 n-word-bytes
))
413 (inst cmpw where bsp-tn
)
420 ;;;; Closure indexing.
422 (define-vop (closure-index-ref word-index-ref
)
423 (:variant closure-info-offset fun-pointer-lowtag
)
424 (:translate %closure-index-ref
))
426 (define-vop (funcallable-instance-info word-index-ref
)
427 (:variant funcallable-instance-info-offset fun-pointer-lowtag
)
428 (:translate %funcallable-instance-info
))
430 (define-vop (set-funcallable-instance-info word-index-set
)
431 (:variant funcallable-instance-info-offset fun-pointer-lowtag
)
432 (:translate %set-funcallable-instance-info
))
434 (define-vop (closure-ref slot-ref
)
435 (:variant closure-info-offset fun-pointer-lowtag
))
437 (define-vop (closure-init slot-set
)
438 (:variant closure-info-offset fun-pointer-lowtag
))
440 (define-vop (closure-init-from-fp)
441 (:args
(object :scs
(descriptor-reg)))
444 (storew cfp-tn object
(+ closure-info-offset offset
) fun-pointer-lowtag
)))
446 ;;;; Value Cell hackery.
448 (define-vop (value-cell-ref cell-ref
)
449 (:variant value-cell-value-slot other-pointer-lowtag
))
451 (define-vop (value-cell-set cell-set
)
452 (:variant value-cell-value-slot other-pointer-lowtag
))
456 ;;;; Instance hackery:
458 (define-vop (instance-length)
460 (:translate %instance-length
)
461 (:args
(struct :scs
(descriptor-reg)))
462 (:temporary
(:scs
(non-descriptor-reg)) temp
)
463 (:results
(res :scs
(unsigned-reg)))
464 (:result-types positive-fixnum
)
466 (loadw temp struct
0 instance-pointer-lowtag
)
467 (inst srwi res temp n-widetag-bits
)))
469 (define-vop (instance-index-ref word-index-ref
)
471 (:translate %instance-ref
)
472 (:variant instance-slots-offset instance-pointer-lowtag
)
473 (:arg-types instance positive-fixnum
))
475 (define-vop (instance-index-set word-index-set
)
477 (:translate %instance-set
)
478 (:variant instance-slots-offset instance-pointer-lowtag
)
479 (:arg-types instance positive-fixnum
*))
481 #!+compare-and-swap-vops
482 (define-vop (%compare-and-swap-instance-ref word-index-cas
)
484 (:translate %compare-and-swap-instance-ref
)
485 (:variant instance-slots-offset instance-pointer-lowtag
)
486 (:arg-types instance tagged-num
* *))
489 ;;;; Code object frobbing.
491 (define-vop (code-header-ref word-index-ref
)
492 (:translate code-header-ref
)
494 (:variant
0 other-pointer-lowtag
))
496 (define-vop (code-header-set word-index-set
)
497 (:translate code-header-set
)
499 (:variant
0 other-pointer-lowtag
))
503 ;;;; raw instance slot accessors
505 (defun offset-for-raw-slot (instance-length index n-words
)
506 (+ (* (- instance-length instance-slots-offset index
(1- n-words
))
508 (- instance-pointer-lowtag
)))
510 (define-vop (raw-instance-init/word
)
511 (:args
(object :scs
(descriptor-reg))
512 (value :scs
(unsigned-reg)))
513 (:arg-types
* unsigned-num
)
514 (:info instance-length index
)
516 (inst stw value object
(offset-for-raw-slot instance-length index
1))))
518 (define-vop (raw-instance-atomic-incf/word
)
519 (:translate %raw-instance-atomic-incf
/word
)
521 (:args
(object :scs
(descriptor-reg))
522 (index :scs
(any-reg))
523 (diff :scs
(unsigned-reg)))
524 (:arg-types
* positive-fixnum unsigned-num
)
525 (:temporary
(:sc unsigned-reg
) offset
)
526 (:temporary
(:sc non-descriptor-reg
) sum
)
527 (:results
(result :scs
(unsigned-reg) :from
:load
))
528 (:result-types unsigned-num
)
530 (loadw offset object
0 instance-pointer-lowtag
)
531 ;; offset = (offset >> n-widetag-bits) << 2
532 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
533 (inst subf offset index offset
)
537 (- (* (1- instance-slots-offset
) n-word-bytes
)
538 instance-pointer-lowtag
))
539 ;; load the slot value, add DIFF, write the sum back, and return
540 ;; the original slot value, atomically, and include a memory
544 (inst lwarx result offset object
)
545 (inst add sum result diff
)
546 (inst stwcx. sum offset object
)
550 (define-vop (raw-instance-ref/word
)
551 (:translate %raw-instance-ref
/word
)
553 (:args
(object :scs
(descriptor-reg))
554 (index :scs
(any-reg)))
555 (:arg-types
* positive-fixnum
)
556 (:results
(value :scs
(unsigned-reg)))
557 (:temporary
(:scs
(non-descriptor-reg)) offset
)
558 (:result-types unsigned-num
)
560 (loadw offset object
0 instance-pointer-lowtag
)
561 ;; offset = (offset >> n-widetag-bits) << 2
562 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
563 (inst subf offset index offset
)
567 (- (* (1- instance-slots-offset
) n-word-bytes
)
568 instance-pointer-lowtag
))
569 (inst lwzx value object offset
)))
571 (define-vop (raw-instance-set/word
)
572 (:translate %raw-instance-set
/word
)
574 (:args
(object :scs
(descriptor-reg))
575 (index :scs
(any-reg))
576 (value :scs
(unsigned-reg)))
577 (:arg-types
* positive-fixnum unsigned-num
)
578 (:results
(result :scs
(unsigned-reg)))
579 (:temporary
(:scs
(non-descriptor-reg)) offset
)
580 (:result-types unsigned-num
)
582 (loadw offset object
0 instance-pointer-lowtag
)
583 ;; offset = (offset >> n-widetag-bits) << 2
584 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
585 (inst subf offset index offset
)
589 (- (* (1- instance-slots-offset
) n-word-bytes
)
590 instance-pointer-lowtag
))
591 (inst stwx value object offset
)
592 (move result value
)))
594 (define-vop (raw-instance-init/single
)
595 (:args
(object :scs
(descriptor-reg))
596 (value :scs
(single-reg)))
597 (:arg-types
* single-float
)
598 (:info instance-length index
)
600 (inst stfs value object
(offset-for-raw-slot instance-length index
1))))
602 (define-vop (raw-instance-ref/single
)
603 (:translate %raw-instance-ref
/single
)
605 (:args
(object :scs
(descriptor-reg))
606 (index :scs
(any-reg)))
607 (:arg-types
* positive-fixnum
)
608 (:results
(value :scs
(single-reg)))
609 (:temporary
(:scs
(non-descriptor-reg)) offset
)
610 (:result-types single-float
)
612 (loadw offset object
0 instance-pointer-lowtag
)
613 ;; offset = (offset >> n-widetag-bits) << 2
614 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
615 (inst subf offset index offset
)
619 (- (* (1- instance-slots-offset
) n-word-bytes
)
620 instance-pointer-lowtag
))
621 (inst lfsx value object offset
)))
623 (define-vop (raw-instance-set/single
)
624 (:translate %raw-instance-set
/single
)
626 (:args
(object :scs
(descriptor-reg))
627 (index :scs
(any-reg))
628 (value :scs
(single-reg) :target result
))
629 (:arg-types
* positive-fixnum single-float
)
630 (:results
(result :scs
(single-reg)))
631 (:result-types single-float
)
632 (:temporary
(:scs
(non-descriptor-reg)) offset
)
634 (loadw offset object
0 instance-pointer-lowtag
)
635 ;; offset = (offset >> n-widetag-bits) << 2
636 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
637 (inst subf offset index offset
)
641 (- (* (1- instance-slots-offset
) n-word-bytes
)
642 instance-pointer-lowtag
))
643 (inst stfsx value object offset
)
644 (unless (location= result value
)
645 (inst frsp result value
))))
647 (define-vop (raw-instance-init/double
)
648 (:args
(object :scs
(descriptor-reg))
649 (value :scs
(double-reg)))
650 (:arg-types
* double-float
)
651 (:info instance-length index
)
653 (inst stfd value object
(offset-for-raw-slot instance-length index
2))))
655 (define-vop (raw-instance-ref/double
)
656 (:translate %raw-instance-ref
/double
)
658 (:args
(object :scs
(descriptor-reg))
659 (index :scs
(any-reg)))
660 (:arg-types
* positive-fixnum
)
661 (:results
(value :scs
(double-reg)))
662 (:temporary
(:scs
(non-descriptor-reg)) offset
)
663 (:result-types double-float
)
665 (loadw offset object
0 instance-pointer-lowtag
)
666 ;; offset = (offset >> n-widetag-bits) << 2
667 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
668 (inst subf offset index offset
)
672 (- (* (- instance-slots-offset
2) n-word-bytes
)
673 instance-pointer-lowtag
))
674 (inst lfdx value object offset
)))
676 (define-vop (raw-instance-set/double
)
677 (:translate %raw-instance-set
/double
)
679 (:args
(object :scs
(descriptor-reg))
680 (index :scs
(any-reg))
681 (value :scs
(double-reg) :target result
))
682 (:arg-types
* positive-fixnum double-float
)
683 (:results
(result :scs
(double-reg)))
684 (:result-types double-float
)
685 (:temporary
(:scs
(non-descriptor-reg)) offset
)
687 (loadw offset object
0 instance-pointer-lowtag
)
688 ;; offset = (offset >> n-widetag-bits) << 2
689 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
690 (inst subf offset index offset
)
694 (- (* (- instance-slots-offset
2) n-word-bytes
)
695 instance-pointer-lowtag
))
696 (inst stfdx value object offset
)
697 (unless (location= result value
)
698 (inst fmr result value
))))
700 (define-vop (raw-instance-init/complex-single
)
701 (:args
(object :scs
(descriptor-reg))
702 (value :scs
(complex-single-reg)))
703 (:arg-types
* complex-single-float
)
704 (:info instance-length index
)
706 (inst stfs
(complex-single-reg-real-tn value
)
707 object
(offset-for-raw-slot instance-length index
2))
708 (inst stfs
(complex-single-reg-imag-tn value
)
709 object
(offset-for-raw-slot instance-length index
1))))
711 (define-vop (raw-instance-ref/complex-single
)
712 (:translate %raw-instance-ref
/complex-single
)
714 (:args
(object :scs
(descriptor-reg))
715 (index :scs
(any-reg)))
716 (:arg-types
* positive-fixnum
)
717 (:results
(value :scs
(complex-single-reg)))
718 (:temporary
(:scs
(non-descriptor-reg)) offset
)
719 (:result-types complex-single-float
)
721 (loadw offset object
0 instance-pointer-lowtag
)
722 ;; offset = (offset >> n-widetag-bits) << 2
723 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
724 (inst subf offset index offset
)
728 (- (* (- instance-slots-offset
2) n-word-bytes
)
729 instance-pointer-lowtag
))
730 (inst lfsx
(complex-single-reg-real-tn value
) object offset
)
731 (inst addi offset offset n-word-bytes
)
732 (inst lfsx
(complex-single-reg-imag-tn value
) object offset
)))
734 (define-vop (raw-instance-set/complex-single
)
735 (:translate %raw-instance-set
/complex-single
)
737 (:args
(object :scs
(descriptor-reg))
738 (index :scs
(any-reg))
739 (value :scs
(complex-single-reg) :target result
))
740 (:arg-types
* positive-fixnum complex-single-float
)
741 (:results
(result :scs
(complex-single-reg)))
742 (:result-types complex-single-float
)
743 (:temporary
(:scs
(non-descriptor-reg)) offset
)
745 (loadw offset object
0 instance-pointer-lowtag
)
746 ;; offset = (offset >> n-widetag-bits) << 2
747 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
748 (inst subf offset index offset
)
752 (- (* (- instance-slots-offset
2) n-word-bytes
)
753 instance-pointer-lowtag
))
754 (let ((value-real (complex-single-reg-real-tn value
))
755 (result-real (complex-single-reg-real-tn result
)))
756 (inst stfsx value-real object offset
)
757 (unless (location= result-real value-real
)
758 (inst frsp result-real value-real
)))
759 (inst addi offset offset n-word-bytes
)
760 (let ((value-imag (complex-single-reg-imag-tn value
))
761 (result-imag (complex-single-reg-imag-tn result
)))
762 (inst stfsx value-imag object offset
)
763 (unless (location= result-imag value-imag
)
764 (inst frsp result-imag value-imag
)))))
766 (define-vop (raw-instance-init/complex-double
)
767 (:args
(object :scs
(descriptor-reg))
768 (value :scs
(complex-double-reg)))
769 (:arg-types
* complex-double-float
)
770 (:info instance-length index
)
772 (inst stfd
(complex-single-reg-real-tn value
)
773 object
(offset-for-raw-slot instance-length index
4))
774 (inst stfd
(complex-double-reg-imag-tn value
)
775 object
(offset-for-raw-slot instance-length index
2))))
777 (define-vop (raw-instance-ref/complex-double
)
778 (:translate %raw-instance-ref
/complex-double
)
780 (:args
(object :scs
(descriptor-reg))
781 (index :scs
(any-reg)))
782 (:arg-types
* positive-fixnum
)
783 (:results
(value :scs
(complex-double-reg)))
784 (:temporary
(:scs
(non-descriptor-reg)) offset
)
785 (:result-types complex-double-float
)
787 (loadw offset object
0 instance-pointer-lowtag
)
788 ;; offset = (offset >> n-widetag-bits) << 2
789 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
790 (inst subf offset index offset
)
794 (- (* (- instance-slots-offset
4) n-word-bytes
)
795 instance-pointer-lowtag
))
796 (inst lfdx
(complex-double-reg-real-tn value
) object offset
)
797 (inst addi offset offset
(* 2 n-word-bytes
))
798 (inst lfdx
(complex-double-reg-imag-tn value
) object offset
)))
800 (define-vop (raw-instance-set/complex-double
)
801 (:translate %raw-instance-set
/complex-double
)
803 (:args
(object :scs
(descriptor-reg))
804 (index :scs
(any-reg))
805 (value :scs
(complex-double-reg) :target result
))
806 (:arg-types
* positive-fixnum complex-double-float
)
807 (:results
(result :scs
(complex-double-reg)))
808 (:result-types complex-double-float
)
809 (:temporary
(:scs
(non-descriptor-reg)) offset
)
811 (loadw offset object
0 instance-pointer-lowtag
)
812 ;; offset = (offset >> n-widetag-bits) << 2
813 (inst rlwinm offset offset
(- 32 (- n-widetag-bits
2)) (- n-widetag-bits
2) 29)
814 (inst subf offset index offset
)
818 (- (* (- instance-slots-offset
4) n-word-bytes
)
819 instance-pointer-lowtag
))
820 (let ((value-real (complex-double-reg-real-tn value
))
821 (result-real (complex-double-reg-real-tn result
)))
822 (inst stfdx value-real object offset
)
823 (unless (location= result-real value-real
)
824 (inst fmr result-real value-real
)))
825 (inst addi offset offset
(* 2 n-word-bytes
))
826 (let ((value-imag (complex-double-reg-imag-tn value
))
827 (result-imag (complex-double-reg-imag-tn result
)))
828 (inst stfdx value-imag object offset
)
829 (unless (location= result-imag value-imag
)
830 (inst fmr result-imag value-imag
)))))