1 ;;;; various primitive memory access VOPs for the x86 VM
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 ;;;; data object ref/set stuff
17 (:args (object :scs (descriptor-reg)))
18 (:info name offset lowtag)
20 (:results (result :scs (descriptor-reg any-reg)))
22 (loadw result object offset lowtag)))
24 (define-vop (set-slot)
25 (:args (object :scs (descriptor-reg))
26 (value :scs (descriptor-reg any-reg immediate)))
27 (:temporary (:sc descriptor-reg) temp)
28 (:info name offset lowtag)
32 (if (sc-is value immediate)
33 (let ((val (tn-value value)))
34 (move-immediate (make-ea :qword
36 :disp (- (* offset n-word-bytes)
42 (+ nil-value (static-symbol-offset val)))
44 (logior (ash (char-code val) n-widetag-bits)
47 ;; Else, value not immediate.
48 (storew value object offset lowtag))))
50 (define-vop (compare-and-swap-slot)
51 (:args (object :scs (descriptor-reg) :to :eval)
52 (old :scs (descriptor-reg any-reg) :target rax)
53 (new :scs (descriptor-reg any-reg)))
54 (:temporary (:sc descriptor-reg :offset rax-offset
55 :from (:argument 1) :to :result :target result)
57 (:info name offset lowtag)
59 (:results (result :scs (descriptor-reg any-reg)))
62 (inst cmpxchg (make-ea :qword :base object
63 :disp (- (* offset n-word-bytes) lowtag))
67 ;;;; symbol hacking VOPs
69 (define-vop (%compare-and-swap-symbol-value)
70 (:translate %compare-and-swap-symbol-value)
71 (:args (symbol :scs (descriptor-reg) :to (:result 1))
72 (old :scs (descriptor-reg any-reg) :target rax)
73 (new :scs (descriptor-reg any-reg)))
74 (:temporary (:sc descriptor-reg :offset rax-offset) rax)
76 (:temporary (:sc descriptor-reg) tls)
77 (:results (result :scs (descriptor-reg any-reg)))
81 ;; This code has two pathological cases: NO-TLS-VALUE-MARKER
82 ;; or UNBOUND-MARKER as NEW: in either case we would end up
83 ;; doing possible damage with CMPXCHG -- so don't do that!
84 (let ((unbound (generate-error-code vop 'unbound-symbol-error symbol))
89 (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
90 ;; Thread-local area, no LOCK needed.
91 (inst cmpxchg (make-ea :qword :base thread-base-tn
94 (inst cmp rax no-tls-value-marker-widetag)
97 (inst cmpxchg (make-ea :qword :base symbol
98 :disp (- (* symbol-value-slot n-word-bytes)
104 (inst cmp result unbound-marker-widetag)
105 (inst jmp :e unbound))))
107 (define-vop (%set-symbol-global-value cell-set)
108 (:variant symbol-value-slot other-pointer-lowtag))
110 (define-vop (fast-symbol-global-value cell-ref)
111 (:variant symbol-value-slot other-pointer-lowtag)
113 (:translate symbol-global-value))
115 (define-vop (symbol-global-value)
117 (:translate symbol-global-value)
118 (:args (object :scs (descriptor-reg) :to (:result 1)))
119 (:results (value :scs (descriptor-reg any-reg)))
121 (:save-p :compute-only)
123 (let ((err-lab (generate-error-code vop 'unbound-symbol-error object)))
124 (loadw value object symbol-value-slot other-pointer-lowtag)
125 (inst cmp value unbound-marker-widetag)
126 (inst jmp :e err-lab))))
131 (:args (symbol :scs (descriptor-reg))
132 (value :scs (descriptor-reg any-reg)))
133 (:temporary (:sc descriptor-reg) tls)
135 (let ((global-val (gen-label))
137 (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag)
138 (inst cmp (make-ea :qword :base thread-base-tn :scale 1 :index tls)
139 no-tls-value-marker-widetag)
140 (inst jmp :z global-val)
141 (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls)
144 (emit-label global-val)
145 (storew value symbol symbol-value-slot other-pointer-lowtag)
148 ;; With Symbol-Value, we check that the value isn't the trap object. So
149 ;; Symbol-Value of NIL is NIL.
150 (define-vop (symbol-value)
151 (:translate symbol-value)
153 (:args (object :scs (descriptor-reg) :to (:result 1)))
154 (:results (value :scs (descriptor-reg any-reg)))
156 (:save-p :compute-only)
158 (let* ((check-unbound-label (gen-label))
159 (err-lab (generate-error-code vop 'unbound-symbol-error object))
160 (ret-lab (gen-label)))
161 (loadw value object symbol-tls-index-slot other-pointer-lowtag)
162 (inst mov value (make-ea :qword :base thread-base-tn
163 :index value :scale 1))
164 (inst cmp value no-tls-value-marker-widetag)
165 (inst jmp :ne check-unbound-label)
166 (loadw value object symbol-value-slot other-pointer-lowtag)
167 (emit-label check-unbound-label)
168 (inst cmp value unbound-marker-widetag)
169 (inst jmp :e err-lab)
170 (emit-label ret-lab))))
172 (define-vop (fast-symbol-value symbol-value)
173 ;; KLUDGE: not really fast, in fact, because we're going to have to
174 ;; do a full lookup of the thread-local area anyway. But half of
175 ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
176 ;; unbound", which is used in the implementation of COPY-SYMBOL. --
179 (:translate symbol-value)
181 (let ((ret-lab (gen-label)))
182 (loadw value object symbol-tls-index-slot other-pointer-lowtag)
184 (make-ea :qword :base thread-base-tn :index value :scale 1))
185 (inst cmp value no-tls-value-marker-widetag)
186 (inst jmp :ne ret-lab)
187 (loadw value object symbol-value-slot other-pointer-lowtag)
188 (emit-label ret-lab)))))
192 (define-vop (symbol-value symbol-global-value)
193 (:translate symbol-value))
194 (define-vop (fast-symbol-value fast-symbol-global-value)
195 (:translate symbol-value))
196 (define-vop (set %set-symbol-global-value)))
202 (:args (object :scs (descriptor-reg)))
204 (:temporary (:sc descriptor-reg #+nil(:from (:argument 0))) value)
206 (let ((check-unbound-label (gen-label)))
207 (loadw value object symbol-tls-index-slot other-pointer-lowtag)
209 (make-ea :qword :base thread-base-tn :index value :scale 1))
210 (inst cmp value no-tls-value-marker-widetag)
211 (inst jmp :ne check-unbound-label)
212 (loadw value object symbol-value-slot other-pointer-lowtag)
213 (emit-label check-unbound-label)
214 (inst cmp value unbound-marker-widetag))))
220 (:args (object :scs (descriptor-reg)))
223 (inst cmp (make-ea-for-object-slot object symbol-value-slot
224 other-pointer-lowtag)
225 unbound-marker-widetag)))
228 (define-vop (symbol-hash)
230 (:translate symbol-hash)
231 (:args (symbol :scs (descriptor-reg)))
232 (:results (res :scs (any-reg)))
233 (:result-types positive-fixnum)
235 ;; The symbol-hash slot of NIL holds NIL because it is also the
236 ;; cdr slot, so we have to strip off the three low bits to make sure
237 ;; it is a fixnum. The lowtag selection magic that is required to
238 ;; ensure this is explained in the comment in objdef.lisp
239 (loadw res symbol symbol-hash-slot other-pointer-lowtag)
240 (inst and res (lognot #b111))))
242 ;;;; fdefinition (FDEFN) objects
244 (define-vop (fdefn-fun cell-ref) ; /pfw - alpha
245 (:variant fdefn-fun-slot other-pointer-lowtag))
247 (define-vop (safe-fdefn-fun)
248 (:args (object :scs (descriptor-reg) :to (:result 1)))
249 (:results (value :scs (descriptor-reg any-reg)))
251 (:save-p :compute-only)
253 (loadw value object fdefn-fun-slot other-pointer-lowtag)
254 (inst cmp value nil-value)
255 (let ((err-lab (generate-error-code vop 'undefined-fun-error object)))
256 (inst jmp :e err-lab))))
258 (define-vop (set-fdefn-fun)
260 (:translate (setf fdefn-fun))
261 (:args (function :scs (descriptor-reg) :target result)
262 (fdefn :scs (descriptor-reg)))
263 (:temporary (:sc unsigned-reg) raw)
264 (:temporary (:sc byte-reg) type)
265 (:results (result :scs (descriptor-reg)))
267 (load-type type function (- fun-pointer-lowtag))
269 (make-ea :byte :base function
270 :disp (- (* simple-fun-code-offset n-word-bytes)
271 fun-pointer-lowtag)))
272 (inst cmp type simple-fun-header-widetag)
273 (inst jmp :e NORMAL-FUN)
274 (inst lea raw (make-fixup "closure_tramp" :foreign))
276 (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
277 (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
278 (move result function)))
280 (define-vop (fdefn-makunbound)
282 (:translate fdefn-makunbound)
283 (:args (fdefn :scs (descriptor-reg) :target result))
284 (:results (result :scs (descriptor-reg)))
286 (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag)
287 (storew (make-fixup "undefined_tramp" :foreign)
288 fdefn fdefn-raw-addr-slot other-pointer-lowtag)
289 (move result fdefn)))
291 ;;;; binding and unbinding
293 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
294 ;;; the symbol on the binding stack and stuff the new value into the
299 (:args (val :scs (any-reg descriptor-reg))
300 (symbol :scs (descriptor-reg)))
301 (:temporary (:sc unsigned-reg) tls-index bsp)
303 (let ((tls-index-valid (gen-label)))
304 (load-binding-stack-pointer bsp)
305 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
306 (inst add bsp (* binding-size n-word-bytes))
307 (store-binding-stack-pointer bsp)
308 (inst or tls-index tls-index)
309 (inst jmp :ne tls-index-valid)
310 (inst mov tls-index symbol)
311 (inst lea temp-reg-tn
312 (make-ea :qword :disp
313 (make-fixup (ecase (tn-offset tls-index)
314 (#.rax-offset 'alloc-tls-index-in-rax)
315 (#.rcx-offset 'alloc-tls-index-in-rcx)
316 (#.rdx-offset 'alloc-tls-index-in-rdx)
317 (#.rbx-offset 'alloc-tls-index-in-rbx)
318 (#.rsi-offset 'alloc-tls-index-in-rsi)
319 (#.rdi-offset 'alloc-tls-index-in-rdi)
320 (#.r8-offset 'alloc-tls-index-in-r8)
321 (#.r9-offset 'alloc-tls-index-in-r9)
322 (#.r10-offset 'alloc-tls-index-in-r10)
323 (#.r12-offset 'alloc-tls-index-in-r12)
324 (#.r13-offset 'alloc-tls-index-in-r13)
325 (#.r14-offset 'alloc-tls-index-in-r14)
326 (#.r15-offset 'alloc-tls-index-in-r15))
328 (inst call temp-reg-tn)
329 (emit-label tls-index-valid)
330 (inst push (make-ea :qword :base thread-base-tn :scale 1 :index tls-index))
331 (popw bsp (- binding-value-slot binding-size))
332 (storew symbol bsp (- binding-symbol-slot binding-size))
333 (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
338 (:args (val :scs (any-reg descriptor-reg))
339 (symbol :scs (descriptor-reg)))
340 (:temporary (:sc unsigned-reg) temp bsp)
342 (load-symbol-value bsp *binding-stack-pointer*)
343 (loadw temp symbol symbol-value-slot other-pointer-lowtag)
344 (inst add bsp (* binding-size n-word-bytes))
345 (store-symbol-value bsp *binding-stack-pointer*)
346 (storew temp bsp (- binding-value-slot binding-size))
347 (storew symbol bsp (- binding-symbol-slot binding-size))
348 (storew val symbol symbol-value-slot other-pointer-lowtag)))
352 (:temporary (:sc unsigned-reg) temp bsp tls-index)
354 (load-binding-stack-pointer bsp)
355 ;; Load SYMBOL from stack, and get the TLS-INDEX
356 (loadw temp bsp (- binding-symbol-slot binding-size))
357 (loadw tls-index temp symbol-tls-index-slot other-pointer-lowtag)
358 ;; Load VALUE from stack, the restore it to the TLS area.
359 (loadw temp bsp (- binding-value-slot binding-size))
360 (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
362 ;; Zero out the stack.
363 (storew 0 bsp (- binding-symbol-slot binding-size))
364 (storew 0 bsp (- binding-value-slot binding-size))
365 (inst sub bsp (* binding-size n-word-bytes))
366 (store-binding-stack-pointer bsp)))
370 (:temporary (:sc unsigned-reg) symbol value bsp)
372 (load-symbol-value bsp *binding-stack-pointer*)
373 (loadw symbol bsp (- binding-symbol-slot binding-size))
374 (loadw value bsp (- binding-value-slot binding-size))
375 (storew value symbol symbol-value-slot other-pointer-lowtag)
376 (storew 0 bsp (- binding-symbol-slot binding-size))
377 (storew 0 bsp (- binding-value-slot binding-size))
378 (inst sub bsp (* binding-size n-word-bytes))
379 (store-symbol-value bsp *binding-stack-pointer*)))
381 (define-vop (unbind-to-here)
382 (:args (where :scs (descriptor-reg any-reg)))
383 (:temporary (:sc unsigned-reg) symbol value bsp #!+sb-thread tls-index)
385 (load-binding-stack-pointer bsp)
390 (loadw symbol bsp (- binding-symbol-slot binding-size))
391 (inst or symbol symbol)
393 ;; Bind stack debug sentinels have the unbound marker in the symbol slot
394 (inst cmp symbol unbound-marker-widetag)
396 (loadw value bsp (- binding-value-slot binding-size))
398 (storew value symbol symbol-value-slot other-pointer-lowtag)
400 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag)
402 (inst mov (make-ea :qword :base thread-base-tn :scale 1 :index tls-index)
404 (storew 0 bsp (- binding-symbol-slot binding-size))
407 (storew 0 bsp (- binding-value-slot binding-size))
408 (inst sub bsp (* binding-size n-word-bytes))
411 (store-binding-stack-pointer bsp)
415 (define-vop (bind-sentinel)
416 (:temporary (:sc unsigned-reg) bsp)
418 (load-binding-stack-pointer bsp)
419 (inst add bsp (* binding-size n-word-bytes))
420 (storew unbound-marker-widetag bsp (- binding-symbol-slot binding-size))
421 (storew rbp-tn bsp (- binding-value-slot binding-size))
422 (store-binding-stack-pointer bsp)))
424 (define-vop (unbind-sentinel)
425 (:temporary (:sc unsigned-reg) bsp)
427 (load-binding-stack-pointer bsp)
428 (storew 0 bsp (- binding-value-slot binding-size))
429 (storew 0 bsp (- binding-symbol-slot binding-size))
430 (inst sub bsp (* binding-size n-word-bytes))
431 (store-binding-stack-pointer bsp)))
436 ;;;; closure indexing
438 (define-full-reffer closure-index-ref *
439 closure-info-offset fun-pointer-lowtag
440 (any-reg descriptor-reg) * %closure-index-ref)
442 (define-full-setter set-funcallable-instance-info *
443 funcallable-instance-info-offset fun-pointer-lowtag
444 (any-reg descriptor-reg) * %set-funcallable-instance-info)
446 (define-full-reffer funcallable-instance-info *
447 funcallable-instance-info-offset fun-pointer-lowtag
448 (descriptor-reg any-reg) * %funcallable-instance-info)
450 (define-vop (closure-ref slot-ref)
451 (:variant closure-info-offset fun-pointer-lowtag))
453 (define-vop (closure-init slot-set)
454 (:variant closure-info-offset fun-pointer-lowtag))
456 ;;;; value cell hackery
458 (define-vop (value-cell-ref cell-ref)
459 (:variant value-cell-value-slot other-pointer-lowtag))
461 (define-vop (value-cell-set cell-set)
462 (:variant value-cell-value-slot other-pointer-lowtag))
464 ;;;; structure hackery
466 (define-vop (instance-length)
468 (:translate %instance-length)
469 (:args (struct :scs (descriptor-reg)))
470 (:results (res :scs (unsigned-reg)))
471 (:result-types positive-fixnum)
473 (loadw res struct 0 instance-pointer-lowtag)
474 (inst shr res n-widetag-bits)))
476 (define-full-reffer instance-index-ref * instance-slots-offset
477 instance-pointer-lowtag (any-reg descriptor-reg) * %instance-ref)
479 (define-full-setter instance-index-set * instance-slots-offset
480 instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set)
482 (define-full-compare-and-swap %compare-and-swap-instance-ref instance
483 instance-slots-offset instance-pointer-lowtag
484 (any-reg descriptor-reg) *
485 %compare-and-swap-instance-ref)
487 ;;;; code object frobbing
489 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
490 (any-reg descriptor-reg) * code-header-ref)
492 (define-full-setter code-header-set * 0 other-pointer-lowtag
493 (any-reg descriptor-reg) * code-header-set)
495 ;;;; raw instance slot accessors
497 (defun make-ea-for-raw-slot (object index instance-length
498 &optional (adjustment 0))
499 (if (integerp instance-length)
500 ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length
504 :disp (+ (* (- instance-length instance-slots-offset index)
506 (- instance-pointer-lowtag)
510 (make-ea :qword :base object :index instance-length
511 :disp (+ (* (1- instance-slots-offset) n-word-bytes)
512 (- instance-pointer-lowtag)
515 (make-ea :qword :base object :index instance-length
517 :disp (+ (* (1- instance-slots-offset) n-word-bytes)
518 (- instance-pointer-lowtag)
520 (* index (- n-word-bytes))))))))
522 (define-vop (raw-instance-ref/word)
523 (:translate %raw-instance-ref/word)
525 (:args (object :scs (descriptor-reg)) (index :scs (any-reg)))
526 (:arg-types * tagged-num)
527 (:temporary (:sc unsigned-reg) tmp)
528 (:results (value :scs (unsigned-reg)))
529 (:result-types unsigned-num)
531 (loadw tmp object 0 instance-pointer-lowtag)
532 (inst shr tmp n-widetag-bits)
535 (inst mov value (make-ea-for-raw-slot object index tmp))))
537 (define-vop (raw-instance-ref-c/word)
538 (:translate %raw-instance-ref/word)
540 (:args (object :scs (descriptor-reg)))
541 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
542 #.instance-pointer-lowtag
543 #.instance-slots-offset)))
545 (:temporary (:sc unsigned-reg) tmp)
546 (:results (value :scs (unsigned-reg)))
547 (:result-types unsigned-num)
549 (loadw tmp object 0 instance-pointer-lowtag)
550 (inst shr tmp n-widetag-bits)
551 (inst mov value (make-ea-for-raw-slot object index tmp))))
553 (define-vop (raw-instance-set/word)
554 (:translate %raw-instance-set/word)
556 (:args (object :scs (descriptor-reg))
557 (index :scs (any-reg))
558 (value :scs (unsigned-reg) :target result))
559 (:arg-types * tagged-num unsigned-num)
560 (:temporary (:sc unsigned-reg) tmp)
561 (:results (result :scs (unsigned-reg)))
562 (:result-types unsigned-num)
564 (loadw tmp object 0 instance-pointer-lowtag)
565 (inst shr tmp n-widetag-bits)
568 (inst mov (make-ea-for-raw-slot object index tmp) value)
569 (move result value)))
571 (define-vop (raw-instance-set-c/word)
572 (:translate %raw-instance-set/word)
574 (:args (object :scs (descriptor-reg))
575 (value :scs (unsigned-reg) :target result))
576 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
577 #.instance-pointer-lowtag
578 #.instance-slots-offset))
581 (:temporary (:sc unsigned-reg) tmp)
582 (:results (result :scs (unsigned-reg)))
583 (:result-types unsigned-num)
585 (loadw tmp object 0 instance-pointer-lowtag)
586 (inst shr tmp n-widetag-bits)
587 (inst mov (make-ea-for-raw-slot object index tmp) value)
588 (move result value)))
590 (define-vop (raw-instance-init/word)
591 (:args (object :scs (descriptor-reg))
592 (value :scs (unsigned-reg)))
593 (:arg-types * unsigned-num)
594 (:info instance-length index)
596 (inst mov (make-ea-for-raw-slot object index instance-length) value)))
598 (define-vop (raw-instance-atomic-incf-c/word)
599 (:translate %raw-instance-atomic-incf/word)
601 (:args (object :scs (descriptor-reg))
602 (diff :scs (signed-reg) :target result))
603 (:arg-types * (:constant (load/store-index #.n-word-bytes
604 #.instance-pointer-lowtag
605 #.instance-slots-offset))
608 (:temporary (:sc unsigned-reg) tmp)
609 (:results (result :scs (unsigned-reg)))
610 (:result-types unsigned-num)
612 (loadw tmp object 0 instance-pointer-lowtag)
613 (inst shr tmp n-widetag-bits)
614 (inst xadd (make-ea-for-raw-slot object index tmp) diff :lock)
617 (define-vop (raw-instance-ref/single)
618 (:translate %raw-instance-ref/single)
620 (:args (object :scs (descriptor-reg))
621 (index :scs (any-reg)))
622 (:arg-types * positive-fixnum)
623 (:temporary (:sc unsigned-reg) tmp)
624 (:results (value :scs (single-reg)))
625 (:result-types single-float)
627 (loadw tmp object 0 instance-pointer-lowtag)
628 (inst shr tmp n-widetag-bits)
631 (inst movss value (make-ea-for-raw-slot object index tmp))))
633 (define-vop (raw-instance-ref-c/single)
634 (:translate %raw-instance-ref/single)
636 (:args (object :scs (descriptor-reg)))
637 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
638 #.instance-pointer-lowtag
639 #.instance-slots-offset)))
641 (:temporary (:sc unsigned-reg) tmp)
642 (:results (value :scs (single-reg)))
643 (:result-types single-float)
645 (loadw tmp object 0 instance-pointer-lowtag)
646 (inst shr tmp n-widetag-bits)
647 (inst movss value (make-ea-for-raw-slot object index tmp))))
649 (define-vop (raw-instance-set/single)
650 (:translate %raw-instance-set/single)
652 (:args (object :scs (descriptor-reg))
653 (index :scs (any-reg))
654 (value :scs (single-reg) :target result))
655 (:arg-types * positive-fixnum single-float)
656 (:temporary (:sc unsigned-reg) tmp)
657 (:results (result :scs (single-reg)))
658 (:result-types single-float)
660 (loadw tmp object 0 instance-pointer-lowtag)
661 (inst shr tmp n-widetag-bits)
664 (inst movss (make-ea-for-raw-slot object index tmp) value)
665 (unless (location= result value)
666 (inst movss result value))))
668 (define-vop (raw-instance-set-c/single)
669 (:translate %raw-instance-set/single)
671 (:args (object :scs (descriptor-reg))
672 (value :scs (single-reg) :target result))
673 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
674 #.instance-pointer-lowtag
675 #.instance-slots-offset))
678 (:temporary (:sc unsigned-reg) tmp)
679 (:results (result :scs (single-reg)))
680 (:result-types single-float)
682 (loadw tmp object 0 instance-pointer-lowtag)
683 (inst shr tmp n-widetag-bits)
684 (inst movss (make-ea-for-raw-slot object index tmp) value)
685 (unless (location= result value)
686 (inst movss result value))))
688 (define-vop (raw-instance-init/single)
689 (:args (object :scs (descriptor-reg))
690 (value :scs (single-reg)))
691 (:arg-types * single-float)
692 (:info instance-length index)
694 (inst movss (make-ea-for-raw-slot object index instance-length) value)))
696 (define-vop (raw-instance-ref/double)
697 (:translate %raw-instance-ref/double)
699 (:args (object :scs (descriptor-reg))
700 (index :scs (any-reg)))
701 (:arg-types * positive-fixnum)
702 (:temporary (:sc unsigned-reg) tmp)
703 (:results (value :scs (double-reg)))
704 (:result-types double-float)
706 (loadw tmp object 0 instance-pointer-lowtag)
707 (inst shr tmp n-widetag-bits)
710 (inst movsd value (make-ea-for-raw-slot object index tmp))))
712 (define-vop (raw-instance-ref-c/double)
713 (:translate %raw-instance-ref/double)
715 (:args (object :scs (descriptor-reg)))
716 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
717 #.instance-pointer-lowtag
718 #.instance-slots-offset)))
720 (:temporary (:sc unsigned-reg) tmp)
721 (:results (value :scs (double-reg)))
722 (:result-types double-float)
724 (loadw tmp object 0 instance-pointer-lowtag)
725 (inst shr tmp n-widetag-bits)
726 (inst movsd value (make-ea-for-raw-slot object index tmp))))
728 (define-vop (raw-instance-set/double)
729 (:translate %raw-instance-set/double)
731 (:args (object :scs (descriptor-reg))
732 (index :scs (any-reg))
733 (value :scs (double-reg) :target result))
734 (:arg-types * positive-fixnum double-float)
735 (:temporary (:sc unsigned-reg) tmp)
736 (:results (result :scs (double-reg)))
737 (:result-types double-float)
739 (loadw tmp object 0 instance-pointer-lowtag)
740 (inst shr tmp n-widetag-bits)
743 (inst movsd (make-ea-for-raw-slot object index tmp) value)
744 (unless (location= result value)
745 (inst movsd result value))))
747 (define-vop (raw-instance-set-c/double)
748 (:translate %raw-instance-set/double)
750 (:args (object :scs (descriptor-reg))
751 (value :scs (double-reg) :target result))
752 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
753 #.instance-pointer-lowtag
754 #.instance-slots-offset))
757 (:temporary (:sc unsigned-reg) tmp)
758 (:results (result :scs (double-reg)))
759 (:result-types double-float)
761 (loadw tmp object 0 instance-pointer-lowtag)
762 (inst shr tmp n-widetag-bits)
763 (inst movsd (make-ea-for-raw-slot object index tmp) value)
764 (unless (location= result value)
765 (inst movsd result value))))
767 (define-vop (raw-instance-init/double)
768 (:args (object :scs (descriptor-reg))
769 (value :scs (double-reg)))
770 (:arg-types * double-float)
771 (:info instance-length index)
773 (inst movsd (make-ea-for-raw-slot object index instance-length) value)))
775 (define-vop (raw-instance-ref/complex-single)
776 (:translate %raw-instance-ref/complex-single)
778 (:args (object :scs (descriptor-reg))
779 (index :scs (any-reg)))
780 (:arg-types * positive-fixnum)
781 (:temporary (:sc unsigned-reg) tmp)
782 (:results (value :scs (complex-single-reg)))
783 (:result-types complex-single-float)
785 (loadw tmp object 0 instance-pointer-lowtag)
786 (inst shr tmp n-widetag-bits)
789 (let ((real-tn (complex-single-reg-real-tn value)))
790 (inst movss real-tn (make-ea-for-raw-slot object index tmp)))
791 (let ((imag-tn (complex-single-reg-imag-tn value)))
792 (inst movss imag-tn (make-ea-for-raw-slot object index tmp 4)))))
794 (define-vop (raw-instance-ref-c/complex-single)
795 (:translate %raw-instance-ref/complex-single)
797 (:args (object :scs (descriptor-reg)))
798 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
799 #.instance-pointer-lowtag
800 #.instance-slots-offset)))
802 (:temporary (:sc unsigned-reg) tmp)
803 (:results (value :scs (complex-single-reg)))
804 (:result-types complex-single-float)
806 (loadw tmp object 0 instance-pointer-lowtag)
807 (inst shr tmp n-widetag-bits)
808 (let ((real-tn (complex-single-reg-real-tn value)))
809 (inst movss real-tn (make-ea-for-raw-slot object index tmp)))
810 (let ((imag-tn (complex-single-reg-imag-tn value)))
811 (inst movss imag-tn (make-ea-for-raw-slot object index tmp 4)))))
813 (define-vop (raw-instance-set/complex-single)
814 (:translate %raw-instance-set/complex-single)
816 (:args (object :scs (descriptor-reg))
817 (index :scs (any-reg))
818 (value :scs (complex-single-reg) :target result))
819 (:arg-types * positive-fixnum complex-single-float)
820 (:temporary (:sc unsigned-reg) tmp)
821 (:results (result :scs (complex-single-reg)))
822 (:result-types complex-single-float)
824 (loadw tmp object 0 instance-pointer-lowtag)
825 (inst shr tmp n-widetag-bits)
828 (let ((value-real (complex-single-reg-real-tn value))
829 (result-real (complex-single-reg-real-tn result)))
830 (inst movss (make-ea-for-raw-slot object index tmp) value-real)
831 (unless (location= value-real result-real)
832 (inst movss result-real value-real)))
833 (let ((value-imag (complex-single-reg-imag-tn value))
834 (result-imag (complex-single-reg-imag-tn result)))
835 (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag)
836 (unless (location= value-imag result-imag)
837 (inst movss result-imag value-imag)))))
839 (define-vop (raw-instance-set-c/complex-single)
840 (:translate %raw-instance-set/complex-single)
842 (:args (object :scs (descriptor-reg))
843 (value :scs (complex-single-reg) :target result))
844 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
845 #.instance-pointer-lowtag
846 #.instance-slots-offset))
847 complex-single-float)
849 (:temporary (:sc unsigned-reg) tmp)
850 (:results (result :scs (complex-single-reg)))
851 (:result-types complex-single-float)
853 (loadw tmp object 0 instance-pointer-lowtag)
854 (inst shr tmp n-widetag-bits)
855 (let ((value-real (complex-single-reg-real-tn value))
856 (result-real (complex-single-reg-real-tn result)))
857 (inst movss (make-ea-for-raw-slot object index tmp) value-real)
858 (unless (location= value-real result-real)
859 (inst movss result-real value-real)))
860 (let ((value-imag (complex-single-reg-imag-tn value))
861 (result-imag (complex-single-reg-imag-tn result)))
862 (inst movss (make-ea-for-raw-slot object index tmp 4) value-imag)
863 (unless (location= value-imag result-imag)
864 (inst movss result-imag value-imag)))))
866 (define-vop (raw-instance-init/complex-single)
867 (:args (object :scs (descriptor-reg))
868 (value :scs (complex-single-reg)))
869 (:arg-types * complex-single-float)
870 (:info instance-length index)
872 (let ((value-real (complex-single-reg-real-tn value)))
873 (inst movss (make-ea-for-raw-slot object index instance-length) value-real))
874 (let ((value-imag (complex-single-reg-imag-tn value)))
875 (inst movss (make-ea-for-raw-slot object index instance-length 4) value-imag))))
877 (define-vop (raw-instance-ref/complex-double)
878 (:translate %raw-instance-ref/complex-double)
880 (:args (object :scs (descriptor-reg))
881 (index :scs (any-reg)))
882 (:arg-types * positive-fixnum)
883 (:temporary (:sc unsigned-reg) tmp)
884 (:results (value :scs (complex-double-reg)))
885 (:result-types complex-double-float)
887 (loadw tmp object 0 instance-pointer-lowtag)
888 (inst shr tmp n-widetag-bits)
891 (let ((real-tn (complex-double-reg-real-tn value)))
892 (inst movsd real-tn (make-ea-for-raw-slot object index tmp -8)))
893 (let ((imag-tn (complex-double-reg-imag-tn value)))
894 (inst movsd imag-tn (make-ea-for-raw-slot object index tmp)))))
896 (define-vop (raw-instance-ref-c/complex-double)
897 (:translate %raw-instance-ref/complex-double)
899 (:args (object :scs (descriptor-reg)))
900 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
901 #.instance-pointer-lowtag
902 #.instance-slots-offset)))
904 (:temporary (:sc unsigned-reg) tmp)
905 (:results (value :scs (complex-double-reg)))
906 (:result-types complex-double-float)
908 (loadw tmp object 0 instance-pointer-lowtag)
909 (inst shr tmp n-widetag-bits)
910 (let ((real-tn (complex-double-reg-real-tn value)))
911 (inst movsd real-tn (make-ea-for-raw-slot object index tmp -8)))
912 (let ((imag-tn (complex-double-reg-imag-tn value)))
913 (inst movsd imag-tn (make-ea-for-raw-slot object index tmp)))))
915 (define-vop (raw-instance-set/complex-double)
916 (:translate %raw-instance-set/complex-double)
918 (:args (object :scs (descriptor-reg))
919 (index :scs (any-reg))
920 (value :scs (complex-double-reg) :target result))
921 (:arg-types * positive-fixnum complex-double-float)
922 (:temporary (:sc unsigned-reg) tmp)
923 (:results (result :scs (complex-double-reg)))
924 (:result-types complex-double-float)
926 (loadw tmp object 0 instance-pointer-lowtag)
927 (inst shr tmp n-widetag-bits)
930 (let ((value-real (complex-double-reg-real-tn value))
931 (result-real (complex-double-reg-real-tn result)))
932 (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real)
933 (unless (location= value-real result-real)
934 (inst movsd result-real value-real)))
935 (let ((value-imag (complex-double-reg-imag-tn value))
936 (result-imag (complex-double-reg-imag-tn result)))
937 (inst movsd (make-ea-for-raw-slot object index tmp) value-imag)
938 (unless (location= value-imag result-imag)
939 (inst movsd result-imag value-imag)))))
941 (define-vop (raw-instance-set-c/complex-double)
942 (:translate %raw-instance-set/complex-double)
944 (:args (object :scs (descriptor-reg))
945 (value :scs (complex-double-reg) :target result))
946 (:arg-types * (:constant (load/store-index #.sb!vm:n-word-bytes
947 #.instance-pointer-lowtag
948 #.instance-slots-offset))
949 complex-double-float)
951 (:temporary (:sc unsigned-reg) tmp)
952 (:results (result :scs (complex-double-reg)))
953 (:result-types complex-double-float)
955 (loadw tmp object 0 instance-pointer-lowtag)
956 (inst shr tmp n-widetag-bits)
957 (let ((value-real (complex-double-reg-real-tn value))
958 (result-real (complex-double-reg-real-tn result)))
959 (inst movsd (make-ea-for-raw-slot object index tmp -8) value-real)
960 (unless (location= value-real result-real)
961 (inst movsd result-real value-real)))
962 (let ((value-imag (complex-double-reg-imag-tn value))
963 (result-imag (complex-double-reg-imag-tn result)))
964 (inst movsd (make-ea-for-raw-slot object index tmp) value-imag)
965 (unless (location= value-imag result-imag)
966 (inst movsd result-imag value-imag)))))
968 (define-vop (raw-instance-init/complex-double)
969 (:args (object :scs (descriptor-reg))
970 (value :scs (complex-double-reg)))
971 (:arg-types * complex-double-float)
972 (:info instance-length index)
974 (let ((value-real (complex-double-reg-real-tn value)))
975 (inst movsd (make-ea-for-raw-slot object index instance-length -8) value-real))
976 (let ((value-imag (complex-double-reg-imag-tn value)))
977 (inst movsd (make-ea-for-raw-slot object index instance-length) value-imag))))