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
))))
52 ;;;; symbol hacking VOPs
54 ;;; these next two cf the sparc version, by jrd.
55 ;;; FIXME: Deref this ^ reference.
58 ;;; The compiler likes to be able to directly SET symbols.
61 (:args
(symbol :scs
(descriptor-reg))
62 (value :scs
(descriptor-reg any-reg
)))
63 (:temporary
(:sc descriptor-reg
) tls
)
64 ;;(:policy :fast-safe)
66 (let ((global-val (gen-label))
68 (loadw tls symbol symbol-tls-index-slot other-pointer-lowtag
)
70 (inst jmp
:z global-val
)
71 (inst cmp
(make-ea :qword
:base thread-base-tn
:scale
1 :index tls
)
72 unbound-marker-widetag
)
73 (inst jmp
:z global-val
)
74 (inst mov
(make-ea :qword
:base thread-base-tn
:scale
1 :index tls
)
77 (emit-label global-val
)
78 (storew value symbol symbol-value-slot other-pointer-lowtag
)
81 ;; unithreaded it's a lot simpler ...
83 (define-vop (set cell-set
)
84 (:variant symbol-value-slot other-pointer-lowtag
))
86 ;;; Do a cell ref with an error check for being unbound.
87 ;;; XXX stil used? I can't see where -dan
88 (define-vop (checked-cell-ref)
89 (:args
(object :scs
(descriptor-reg) :target obj-temp
))
90 (:results
(value :scs
(descriptor-reg any-reg
)))
93 (:save-p
:compute-only
)
94 (:temporary
(:sc descriptor-reg
:from
(:argument
0)) obj-temp
))
96 ;;; With Symbol-Value, we check that the value isn't the trap object. So
97 ;;; Symbol-Value of NIL is NIL.
99 (define-vop (symbol-value)
100 (:translate symbol-value
)
102 (:args
(object :scs
(descriptor-reg) :to
(:result
1)))
103 (:results
(value :scs
(descriptor-reg any-reg
)))
105 (:save-p
:compute-only
)
107 (let* ((err-lab (generate-error-code vop unbound-symbol-error object
))
108 (ret-lab (gen-label)))
109 (loadw value object symbol-tls-index-slot other-pointer-lowtag
)
110 (inst mov value
(make-ea :qword
:base thread-base-tn
111 :index value
:scale
1))
112 (inst cmp value unbound-marker-widetag
)
113 (inst jmp
:ne ret-lab
)
114 (loadw value object symbol-value-slot other-pointer-lowtag
)
115 (inst cmp value unbound-marker-widetag
)
116 (inst jmp
:e err-lab
)
117 (emit-label ret-lab
))))
120 (define-vop (fast-symbol-value symbol-value
)
121 ;; KLUDGE: not really fast, in fact, because we're going to have to
122 ;; do a full lookup of the thread-local area anyway. But half of
123 ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
124 ;; unbound", which is used in the implementation of COPY-SYMBOL. --
127 (:translate symbol-value
)
129 (let ((ret-lab (gen-label)))
130 (loadw value object symbol-tls-index-slot other-pointer-lowtag
)
132 (make-ea :qword
:base thread-base-tn
:index value
:scale
1))
133 (inst cmp value unbound-marker-widetag
)
134 (inst jmp
:ne ret-lab
)
135 (loadw value object symbol-value-slot other-pointer-lowtag
)
136 (emit-label ret-lab
))))
139 (define-vop (symbol-value)
140 (:translate symbol-value
)
142 (:args
(object :scs
(descriptor-reg) :to
(:result
1)))
143 (:results
(value :scs
(descriptor-reg any-reg
)))
145 (:save-p
:compute-only
)
147 (let ((err-lab (generate-error-code vop unbound-symbol-error object
)))
148 (loadw value object symbol-value-slot other-pointer-lowtag
)
149 (inst cmp value unbound-marker-widetag
)
150 (inst jmp
:e err-lab
))))
153 (define-vop (fast-symbol-value cell-ref
)
154 (:variant symbol-value-slot other-pointer-lowtag
)
156 (:translate symbol-value
))
158 (defknown locked-symbol-global-value-add
(symbol fixnum
) fixnum
())
160 (define-vop (locked-symbol-global-value-add)
161 (:args
(object :scs
(descriptor-reg) :to
:result
)
162 (value :scs
(any-reg) :target result
))
163 (:arg-types
* tagged-num
)
164 (:results
(result :scs
(any-reg) :from
(:argument
1)))
166 (:translate locked-symbol-global-value-add
)
167 (:result-types tagged-num
)
172 (inst add
(make-ea :qword
:base object
173 :disp
(- (* symbol-value-slot n-word-bytes
)
174 other-pointer-lowtag
))
181 (:args
(object :scs
(descriptor-reg)))
184 (:temporary
(:sc descriptor-reg
#+nil
(:from
(:argument
0))) value
)
187 (let ((not-target (gen-label)))
188 (loadw value object symbol-value-slot other-pointer-lowtag
)
189 (inst cmp value unbound-marker-widetag
)
190 (inst jmp
:ne not-target
)
191 (loadw value object symbol-tls-index-slot other-pointer-lowtag
)
192 (inst cmp
(make-ea :qword
:base thread-base-tn
193 :index value
:scale
1) unbound-marker-widetag
)
195 (emit-label not-target
))
197 (loadw value object symbol-value-slot other-pointer-lowtag
)
198 (inst cmp value unbound-marker-widetag
)
199 (inst jmp
:ne target
)
200 (loadw value object symbol-tls-index-slot other-pointer-lowtag
)
201 (inst cmp
(make-ea :qword
:base thread-base-tn
:index value
:scale
1)
202 unbound-marker-widetag
)
203 (inst jmp
:ne target
)))))
209 (:args
(object :scs
(descriptor-reg)))
212 (:temporary
(:sc descriptor-reg
:from
(:argument
0)) value
)
214 (loadw value object symbol-value-slot other-pointer-lowtag
)
215 (inst cmp value unbound-marker-widetag
)
216 (inst jmp
(if not-p
:e
: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 three 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 and res
(lognot #b111
))))
233 ;;;; fdefinition (FDEFN) objects
235 (define-vop (fdefn-fun cell-ref
) ; /pfw - alpha
236 (:variant fdefn-fun-slot other-pointer-lowtag
))
238 (define-vop (safe-fdefn-fun)
239 (:args
(object :scs
(descriptor-reg) :to
(:result
1)))
240 (:results
(value :scs
(descriptor-reg any-reg
)))
242 (:save-p
:compute-only
)
244 (loadw value object fdefn-fun-slot other-pointer-lowtag
)
245 (inst cmp value nil-value
)
246 (let ((err-lab (generate-error-code vop undefined-fun-error object
)))
247 (inst jmp
:e 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
(:sc unsigned-reg
) raw
)
255 (:temporary
(:sc byte-reg
) type
)
256 (:results
(result :scs
(descriptor-reg)))
258 (load-type type function
(- fun-pointer-lowtag
))
260 (make-ea :byte
:base function
261 :disp
(- (* simple-fun-code-offset n-word-bytes
)
262 fun-pointer-lowtag
)))
263 (inst cmp type simple-fun-header-widetag
)
264 (inst jmp
:e NORMAL-FUN
)
265 (inst lea raw
(make-fixup "closure_tramp" :foreign
))
267 (storew function fdefn fdefn-fun-slot other-pointer-lowtag
)
268 (storew raw fdefn fdefn-raw-addr-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 (:results
(result :scs
(descriptor-reg)))
277 (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag
)
278 (storew (make-fixup "undefined_tramp" :foreign
)
279 fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
280 (move result fdefn
)))
282 ;;;; binding and unbinding
284 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
285 ;;; the symbol on the binding stack and stuff the new value into the
290 (:args
(val :scs
(any-reg descriptor-reg
))
291 (symbol :scs
(descriptor-reg)))
292 (:temporary
(:sc unsigned-reg
) tls-index temp bsp
)
294 (let ((tls-index-valid (gen-label)))
295 (load-tl-symbol-value bsp
*binding-stack-pointer
*)
296 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag
)
297 (inst add bsp
(* binding-size n-word-bytes
))
298 (store-tl-symbol-value bsp
*binding-stack-pointer
* temp
)
300 (inst or tls-index tls-index
)
301 (inst jmp
:ne tls-index-valid
)
302 ;; allocate a new tls-index
303 (load-symbol-value tls-index
*free-tls-index
*)
304 (inst add tls-index
8) ;XXX surely we can do this more
305 (store-symbol-value tls-index
*free-tls-index
*) ;succintly
306 (inst sub tls-index
8)
307 (storew tls-index symbol symbol-tls-index-slot other-pointer-lowtag
)
308 (emit-label tls-index-valid
)
310 (make-ea :qword
:base thread-base-tn
:scale
1 :index tls-index
))
311 (storew temp bsp
(- binding-value-slot binding-size
))
312 (storew symbol bsp
(- binding-symbol-slot binding-size
))
313 (inst mov
(make-ea :qword
:base thread-base-tn
:scale
1 :index tls-index
)
318 (:args
(val :scs
(any-reg descriptor-reg
))
319 (symbol :scs
(descriptor-reg)))
320 (:temporary
(:sc unsigned-reg
) temp bsp
)
322 (load-symbol-value bsp
*binding-stack-pointer
*)
323 (loadw temp symbol symbol-value-slot other-pointer-lowtag
)
324 (inst add bsp
(* binding-size n-word-bytes
))
325 (store-symbol-value bsp
*binding-stack-pointer
*)
326 (storew temp bsp
(- binding-value-slot binding-size
))
327 (storew symbol bsp
(- binding-symbol-slot binding-size
))
328 (storew val symbol symbol-value-slot other-pointer-lowtag
)))
334 (:temporary
(:sc unsigned-reg
) symbol value bsp tls-index
)
336 (load-tl-symbol-value bsp
*binding-stack-pointer
*)
337 (loadw symbol bsp
(- binding-symbol-slot binding-size
))
338 (loadw value bsp
(- binding-value-slot binding-size
))
340 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag
)
341 (inst mov
(make-ea :qword
:base thread-base-tn
:scale
1 :index tls-index
)
344 (storew 0 bsp
(- binding-symbol-slot binding-size
))
345 (inst sub bsp
(* binding-size n-word-bytes
))
346 ;; we're done with value, so we can use it as a temp here
347 (store-tl-symbol-value bsp
*binding-stack-pointer
* value
)))
351 (:temporary
(:sc unsigned-reg
) symbol value bsp
)
353 (load-symbol-value bsp
*binding-stack-pointer
*)
354 (loadw symbol bsp
(- binding-symbol-slot binding-size
))
355 (loadw value bsp
(- binding-value-slot binding-size
))
356 (storew value symbol symbol-value-slot other-pointer-lowtag
)
357 (storew 0 bsp
(- binding-symbol-slot binding-size
))
358 (inst sub bsp
(* binding-size n-word-bytes
))
359 (store-symbol-value bsp
*binding-stack-pointer
*)))
362 (define-vop (unbind-to-here)
363 (:args
(where :scs
(descriptor-reg any-reg
)))
364 (:temporary
(:sc unsigned-reg
) symbol value bsp
#!+sb-thread tls-index
)
366 (load-tl-symbol-value bsp
*binding-stack-pointer
*)
371 (loadw symbol bsp
(- binding-symbol-slot binding-size
))
372 (inst or symbol symbol
)
374 (loadw value bsp
(- binding-value-slot binding-size
))
376 (storew value symbol symbol-value-slot other-pointer-lowtag
)
378 (loadw tls-index symbol symbol-tls-index-slot other-pointer-lowtag
)
380 (inst mov
(make-ea :qword
:base thread-base-tn
:scale
1 :index tls-index
)
382 (storew 0 bsp
(- binding-symbol-slot binding-size
))
385 (inst sub bsp
(* binding-size n-word-bytes
))
388 ;; we're done with value, so can use it as a temporary
389 (store-tl-symbol-value bsp
*binding-stack-pointer
* value
)
395 ;;;; closure indexing
397 (define-full-reffer closure-index-ref
*
398 closure-info-offset fun-pointer-lowtag
399 (any-reg descriptor-reg
) * %closure-index-ref
)
401 (define-full-setter set-funcallable-instance-info
*
402 funcallable-instance-info-offset fun-pointer-lowtag
403 (any-reg descriptor-reg
) * %set-funcallable-instance-info
)
405 (define-full-reffer funcallable-instance-info
*
406 funcallable-instance-info-offset fun-pointer-lowtag
407 (descriptor-reg any-reg
) * %funcallable-instance-info
)
409 (define-vop (funcallable-instance-lexenv cell-ref
)
410 (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag
))
412 (define-vop (closure-ref slot-ref
)
413 (:variant closure-info-offset fun-pointer-lowtag
))
415 (define-vop (closure-init slot-set
)
416 (:variant closure-info-offset fun-pointer-lowtag
))
418 ;;;; value cell hackery
420 (define-vop (value-cell-ref cell-ref
)
421 (:variant value-cell-value-slot other-pointer-lowtag
))
423 (define-vop (value-cell-set cell-set
)
424 (:variant value-cell-value-slot other-pointer-lowtag
))
426 ;;;; structure hackery
428 (define-vop (instance-length)
430 (:translate %instance-length
)
431 (:args
(struct :scs
(descriptor-reg)))
432 (:results
(res :scs
(unsigned-reg)))
433 (:result-types positive-fixnum
)
435 (loadw res struct
0 instance-pointer-lowtag
)
436 (inst shr res n-widetag-bits
)))
438 (define-vop (instance-ref slot-ref
)
439 (:variant instance-slots-offset instance-pointer-lowtag
)
441 (:translate %instance-ref
)
442 (:arg-types instance
(:constant index
)))
444 (define-vop (instance-set slot-set
)
446 (:translate %instance-set
)
447 (:variant instance-slots-offset instance-pointer-lowtag
)
448 (:arg-types instance
(:constant index
) *))
450 (define-full-reffer instance-index-ref
* instance-slots-offset
451 instance-pointer-lowtag
(any-reg descriptor-reg
) * %instance-ref
)
453 (define-full-setter instance-index-set
* instance-slots-offset
454 instance-pointer-lowtag
(any-reg descriptor-reg
) * %instance-set
)
457 (defknown %instance-set-conditional
(instance index t t
) t
460 (define-vop (instance-set-conditional)
461 (:translate %instance-set-conditional
)
462 (:args
(object :scs
(descriptor-reg) :to
:eval
)
463 (slot :scs
(any-reg) :to
:result
)
464 (old-value :scs
(descriptor-reg any-reg
) :target rax
)
465 (new-value :scs
(descriptor-reg any-reg
)))
466 (:arg-types instance positive-fixnum
* *)
467 (:temporary
(:sc descriptor-reg
:offset rax-offset
468 :from
(:argument
2) :to
:result
:target result
) rax
)
469 (:results
(result :scs
(descriptor-reg any-reg
)))
470 ;(:guard (backend-featurep :i486))
475 (inst cmpxchg
(make-ea :qword
:base object
:index slot
:scale
1
476 :disp
(- (* instance-slots-offset n-word-bytes
)
477 instance-pointer-lowtag
))
483 ;;;; code object frobbing
485 (define-full-reffer code-header-ref
* 0 other-pointer-lowtag
486 (any-reg descriptor-reg
) * code-header-ref
)
488 (define-full-setter code-header-set
* 0 other-pointer-lowtag
489 (any-reg descriptor-reg
) * code-header-set
)
493 ;;;; raw instance slot accessors
495 (define-vop (raw-instance-ref/word
)
496 (:translate %raw-instance-ref
/word
)
498 (:args
(object :scs
(descriptor-reg)) (index :scs
(any-reg)))
499 (:arg-types
* tagged-num
)
500 (:temporary
(:sc unsigned-reg
) tmp
)
501 (:results
(value :scs
(unsigned-reg)))
502 (:result-types unsigned-num
)
504 (loadw tmp object
0 instance-pointer-lowtag
)
505 (inst shr tmp n-widetag-bits
)
513 :disp
(- (* (1- instance-slots-offset
) n-word-bytes
)
514 instance-pointer-lowtag
)))))
516 (define-vop (raw-instance-set/word
)
517 (:translate %raw-instance-set
/word
)
519 (:args
(object :scs
(descriptor-reg))
520 (index :scs
(any-reg))
521 (value :scs
(unsigned-reg) :target result
))
522 (:arg-types
* tagged-num unsigned-num
)
523 (:temporary
(:sc unsigned-reg
) tmp
)
524 (:results
(result :scs
(unsigned-reg)))
525 (:result-types unsigned-num
)
527 (loadw tmp object
0 instance-pointer-lowtag
)
528 (inst shr tmp n-widetag-bits
)
535 :disp
(- (* (1- instance-slots-offset
) n-word-bytes
)
536 instance-pointer-lowtag
))
538 (move result value
)))
540 (define-vop (raw-instance-ref/single
)
541 (:translate %raw-instance-ref
/single
)
543 (:args
(object :scs
(descriptor-reg))
544 (index :scs
(any-reg)))
545 (:arg-types
* positive-fixnum
)
546 (:temporary
(:sc unsigned-reg
) tmp
)
547 (:results
(value :scs
(single-reg)))
548 (:result-types single-float
)
550 (loadw tmp object
0 instance-pointer-lowtag
)
551 (inst shr tmp n-widetag-bits
)
559 :disp
(- (* (1- instance-slots-offset
) n-word-bytes
)
560 instance-pointer-lowtag
)))))
562 (define-vop (raw-instance-set/single
)
563 (:translate %raw-instance-set
/single
)
565 (:args
(object :scs
(descriptor-reg))
566 (index :scs
(any-reg))
567 (value :scs
(single-reg) :target result
))
568 (:arg-types
* positive-fixnum single-float
)
569 (:temporary
(:sc unsigned-reg
) tmp
)
570 (:results
(result :scs
(single-reg)))
571 (:result-types single-float
)
573 (loadw tmp object
0 instance-pointer-lowtag
)
574 (inst shr tmp n-widetag-bits
)
581 :disp
(- (* (1- instance-slots-offset
) n-word-bytes
)
582 instance-pointer-lowtag
))
584 (unless (location= result value
)
585 (inst movss result value
))))
587 (define-vop (raw-instance-ref/double
)
588 (:translate %raw-instance-ref
/double
)
590 (:args
(object :scs
(descriptor-reg))
591 (index :scs
(any-reg)))
592 (:arg-types
* positive-fixnum
)
593 (:temporary
(:sc unsigned-reg
) tmp
)
594 (:results
(value :scs
(double-reg)))
595 (:result-types double-float
)
597 (loadw tmp object
0 instance-pointer-lowtag
)
598 (inst shr tmp n-widetag-bits
)
606 :disp
(- (* (1- instance-slots-offset
) n-word-bytes
)
607 instance-pointer-lowtag
)))))
609 (define-vop (raw-instance-set/double
)
610 (:translate %raw-instance-set
/double
)
612 (:args
(object :scs
(descriptor-reg))
613 (index :scs
(any-reg))
614 (value :scs
(double-reg) :target result
))
615 (:arg-types
* positive-fixnum double-float
)
616 (:temporary
(:sc unsigned-reg
) tmp
)
617 (:results
(result :scs
(double-reg)))
618 (:result-types double-float
)
620 (loadw tmp object
0 instance-pointer-lowtag
)
621 (inst shr tmp n-widetag-bits
)
628 :disp
(- (* (1- instance-slots-offset
) n-word-bytes
)
629 instance-pointer-lowtag
))
631 (unless (location= result value
)
632 (inst movsd result value
))))
634 (define-vop (raw-instance-ref/complex-single
)
635 (:translate %raw-instance-ref
/complex-single
)
637 (:args
(object :scs
(descriptor-reg))
638 (index :scs
(any-reg)))
639 (:arg-types
* positive-fixnum
)
640 (:temporary
(:sc unsigned-reg
) tmp
)
641 (:results
(value :scs
(complex-single-reg)))
642 (:result-types complex-single-float
)
644 (loadw tmp object
0 instance-pointer-lowtag
)
645 (inst shr tmp n-widetag-bits
)
648 (let ((real-tn (complex-single-reg-real-tn value
)))
654 :disp
(- (* (1- instance-slots-offset
) n-word-bytes
)
655 instance-pointer-lowtag
))))
656 (let ((imag-tn (complex-single-reg-imag-tn value
)))
662 :disp
(+ (* (1- instance-slots-offset
) n-word-bytes
)
664 (- instance-pointer-lowtag
)))))))
666 (define-vop (raw-instance-set/complex-single
)
667 (:translate %raw-instance-set
/complex-single
)
669 (:args
(object :scs
(descriptor-reg))
670 (index :scs
(any-reg))
671 (value :scs
(complex-single-reg) :target result
))
672 (:arg-types
* positive-fixnum complex-single-float
)
673 (:temporary
(:sc unsigned-reg
) tmp
)
674 (:results
(result :scs
(complex-single-reg)))
675 (:result-types complex-single-float
)
677 (loadw tmp object
0 instance-pointer-lowtag
)
678 (inst shr tmp n-widetag-bits
)
681 (let ((value-real (complex-single-reg-real-tn value
))
682 (result-real (complex-single-reg-real-tn result
)))
683 (inst movss
(make-ea :dword
686 :disp
(- (* (1- instance-slots-offset
) n-word-bytes
)
687 instance-pointer-lowtag
))
689 (unless (location= value-real result-real
)
690 (inst movss result-real value-real
)))
691 (let ((value-imag (complex-single-reg-imag-tn value
))
692 (result-imag (complex-single-reg-imag-tn result
)))
693 (inst movss
(make-ea :dword
696 :disp
(+ (* (1- instance-slots-offset
) n-word-bytes
)
698 (- instance-pointer-lowtag
)))
700 (unless (location= value-imag result-imag
)
701 (inst movss result-imag value-imag
)))))
703 (define-vop (raw-instance-ref/complex-double
)
704 (:translate %raw-instance-ref
/complex-double
)
706 (:args
(object :scs
(descriptor-reg))
707 (index :scs
(any-reg)))
708 (:arg-types
* positive-fixnum
)
709 (:temporary
(:sc unsigned-reg
) tmp
)
710 (:results
(value :scs
(complex-double-reg)))
711 (:result-types complex-double-float
)
713 (loadw tmp object
0 instance-pointer-lowtag
)
714 (inst shr tmp n-widetag-bits
)
717 (let ((real-tn (complex-double-reg-real-tn value
)))
723 :disp
(- (* (- instance-slots-offset
2) n-word-bytes
)
724 instance-pointer-lowtag
))))
725 (let ((imag-tn (complex-double-reg-imag-tn value
)))
731 :disp
(- (* (1- instance-slots-offset
) n-word-bytes
)
732 instance-pointer-lowtag
))))))
734 (define-vop (raw-instance-set/complex-double
)
735 (:translate %raw-instance-set
/complex-double
)
737 (:args
(object :scs
(descriptor-reg))
738 (index :scs
(any-reg))
739 (value :scs
(complex-double-reg) :target result
))
740 (:arg-types
* positive-fixnum complex-double-float
)
741 (:temporary
(:sc unsigned-reg
) tmp
)
742 (:results
(result :scs
(complex-double-reg)))
743 (:result-types complex-double-float
)
745 (loadw tmp object
0 instance-pointer-lowtag
)
746 (inst shr tmp n-widetag-bits
)
749 (let ((value-real (complex-double-reg-real-tn value
))
750 (result-real (complex-double-reg-real-tn result
)))
751 (inst movsd
(make-ea :dword
754 :disp
(- (* (- instance-slots-offset
2) n-word-bytes
)
755 instance-pointer-lowtag
))
757 (unless (location= value-real result-real
)
758 (inst movsd result-real value-real
)))
759 (let ((value-imag (complex-double-reg-imag-tn value
))
760 (result-imag (complex-double-reg-imag-tn result
)))
761 (inst movsd
(make-ea :dword
764 :disp
(- (* (1- instance-slots-offset
) n-word-bytes
)
765 instance-pointer-lowtag
))
767 (unless (location= value-imag result-imag
)
768 (inst movsd result-imag value-imag
)))))