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 (progn name
) ; ignore it
33 (generate-set-slot object value temp offset lowtag
)))
35 (defun generate-set-slot (object value temp offset lowtag
&optional zeroed
)
36 (if (sc-is value immediate
)
37 (move-immediate (make-ea :qword
39 :disp
(- (* offset n-word-bytes
)
41 (encode-value-if-immediate value
)
43 ;; Else, value not immediate.
44 (storew value object offset lowtag
)))
46 ;; INIT-SLOT has to know about the :COMPACT-INSTANCE-HEADER feature.
47 (define-vop (init-slot set-slot
)
48 (:info name dx-p offset lowtag
)
51 (if (or #!+compact-instance-header
52 (and (eq name
'%make-structure-instance
) (eql offset
:layout
)))
53 ;; The layout is in the upper half of the header word.
54 ;; FIXME: It would be nice if FIXED-ALLOC could write the header word
55 ;; in one shot, but this is an acceptable workaround.
57 (make-ea :dword
:base object
:disp
(- 4 instance-pointer-lowtag
))
58 (reg-in-size value
:dword
))
59 (generate-set-slot object value temp offset lowtag
(not dx-p
)))))
61 (define-vop (compare-and-swap-slot)
62 (:args
(object :scs
(descriptor-reg) :to
:eval
)
63 (old :scs
(descriptor-reg any-reg
) :target rax
)
64 (new :scs
(descriptor-reg any-reg
)))
65 (:temporary
(:sc descriptor-reg
:offset rax-offset
66 :from
(:argument
1) :to
:result
:target result
)
68 (:info name offset lowtag
)
70 (:results
(result :scs
(descriptor-reg any-reg
)))
73 (inst cmpxchg
(make-ea :qword
:base object
74 :disp
(- (* offset n-word-bytes
) lowtag
))
78 ;;;; symbol hacking VOPs
80 (define-vop (%set-symbol-global-value cell-set
)
81 (:variant symbol-value-slot other-pointer-lowtag
))
83 (define-vop (fast-symbol-global-value cell-ref
)
84 (:variant symbol-value-slot other-pointer-lowtag
)
86 (:translate sym-global-val
))
88 (define-vop (symbol-global-value)
90 (:translate sym-global-val
)
91 (:args
(object :scs
(descriptor-reg) :to
(:result
1)))
92 (:results
(value :scs
(descriptor-reg any-reg
)))
94 (:save-p
:compute-only
)
96 (let ((err-lab (generate-error-code vop
'unbound-symbol-error object
)))
97 (loadw value object symbol-value-slot other-pointer-lowtag
)
98 (inst cmp
(reg-in-size value
:dword
) unbound-marker-widetag
)
99 (inst jmp
:e err-lab
))))
101 ;; Return T if SYMBOL will be (at no later than load time) wired to a TLS index.
102 ;; When a symbol gets a tls index, it is permanently at that index, so it is
103 ;; by some definition "wired", but here the term specifically means that an
104 ;; index can/should be encoded into the instruction for reading that symbol's
105 ;; thread-local value, as contrasted with reading its index from itself.
106 ;; The BIND vop forces wiring; the BOUNDP vop never does, the SET vop doesn't
107 ;; but could, and {FAST-}SYMBOL-VALUE vops optimize their output appropriately
108 ;; based on wiring. Except when a symbol maps into a thread slot, the compiler
109 ;; doesn't care what the actual index is - that's the loader's purview.
110 (defun wired-tls-symbol-p (symbol)
111 (not (null (info :variable
:wired-tls symbol
))))
113 ;; Return the DISP field to use in an EA relative to thread-base-tn
114 (defun load-time-tls-offset (symbol)
115 (let ((where (info :variable
:wired-tls symbol
)))
116 (cond ((integerp where
) where
)
117 (t (make-fixup symbol
:symbol-tls-index
)))))
119 ;; Return T if reference to symbol doesn't need to check for no-tls-value.
120 ;; True of thread struct slots. More generally we could add a declaration.
121 (defun symbol-always-thread-local-p (symbol)
122 (let ((where (info :variable
:wired-tls symbol
)))
123 (or (eq where
:ALWAYS-THREAD-LOCAL
) (integerp where
))))
125 (deftransform %compare-and-swap-symbol-value
((symbol old new
)
126 ((constant-arg symbol
) t t
))
127 (if (eq (info :variable
:kind
(sb!c
::lvar-value symbol
)) :global
)
128 `(%cas-symbol-global-value symbol old new
)
129 (sb!c
::give-up-ir1-transform
)))
131 (macrolet (;; Logic common to thread-aware SET and CAS. CELL is assigned
132 ;; to the location that should be accessed to modify SYMBOL's
133 ;; value either in the TLS or the symbol's value slot as follows:
134 ;; (1) make it look as if the TLS cell were a symbol by biasing
135 ;; upward by other-pointer-lowtag less 1 word.
136 ;; (2) conditionally make CELL point to the symbol itself
137 (compute-virtual-symbol ()
139 (inst mov
(reg-in-size cell
:dword
) (tls-index-of symbol
))
141 (make-ea :qword
:base thread-base-tn
:index cell
142 :disp
(- other-pointer-lowtag
143 (ash symbol-value-slot word-shift
))))
144 (inst cmp
(access-value-slot cell
:dword
) ; TLS reference
145 no-tls-value-marker-widetag
)
146 (inst cmov
:e cell symbol
))) ; now possibly get the symbol
147 (access-wired-tls-val (sym) ; SYM is a symbol
148 `(make-ea :qword
:disp
(load-time-tls-offset ,sym
)
149 :base thread-base-tn
))
150 (access-tls-val (index size
)
151 `(make-ea ,size
:base thread-base-tn
:index
,index
:scale
1))
152 (access-value-slot (sym &optional
(size :qword
)) ; SYM is a TN
154 (:dword
`(make-ea-for-object-slot-half
155 ,sym symbol-value-slot other-pointer-lowtag
))
156 (:qword
`(make-ea-for-object-slot
157 ,sym symbol-value-slot other-pointer-lowtag
)))))
159 (define-vop (%compare-and-swap-symbol-value
)
160 (:translate %compare-and-swap-symbol-value
)
161 (:args
(symbol :scs
(descriptor-reg) :to
(:result
0))
162 (old :scs
(descriptor-reg any-reg
) :target rax
)
163 (new :scs
(descriptor-reg any-reg
)))
164 (:temporary
(:sc descriptor-reg
:offset rax-offset
165 :from
(:argument
1) :to
(:result
0)) rax
)
167 (:temporary
(:sc descriptor-reg
:to
(:result
0)) cell
)
168 (:results
(result :scs
(descriptor-reg any-reg
)))
172 ;; This code has two pathological cases: NO-TLS-VALUE-MARKER
173 ;; or UNBOUND-MARKER as NEW: in either case we would end up
174 ;; doing possible damage with CMPXCHG -- so don't do that!
175 ;; Even worse: don't supply old=NO-TLS-VALUE with a symbol whose
176 ;; tls-index=0, because that would succeed, assigning NEW to each
177 ;; symbol in existence having otherwise no thread-local value.
178 (let ((unbound (generate-error-code vop
'unbound-symbol-error symbol
)))
179 #!+sb-thread
(progn (compute-virtual-symbol)
181 (inst cmpxchg
(access-value-slot cell
) new
:lock
))
182 #!-sb-thread
(progn (move rax old
)
183 ;; is the :LOCK is necessary?
184 (inst cmpxchg
(access-value-slot symbol
) new
:lock
))
185 (inst cmp
(reg-in-size rax
:dword
) unbound-marker-widetag
)
186 (inst jmp
:e unbound
)
189 (define-vop (%cas-symbol-global-value
)
190 (:translate %cas-symbol-global-value
)
191 (:args
(symbol :scs
(descriptor-reg) :to
(:result
0)
192 :load-if
(not (sc-is symbol immediate
)))
193 (old :scs
(descriptor-reg any-reg
) :target rax
)
194 (new :scs
(descriptor-reg any-reg
)))
195 (:temporary
(:sc descriptor-reg
:offset rax-offset
196 :from
(:argument
1) :to
(:result
0)) rax
)
197 (:results
(result :scs
(descriptor-reg any-reg
)))
202 (if (sc-is symbol immediate
)
203 (symbol-slot-addr (tn-value symbol
) symbol-value-slot
)
204 (access-value-slot symbol
))
210 ;; TODO: SET could be shorter for any known wired-tls symbol.
212 (:args
(symbol :scs
(descriptor-reg))
213 (value :scs
(descriptor-reg any-reg
)))
214 (:temporary
(:sc descriptor-reg
) cell
)
216 ;; Compute the address into which to store. CMOV can only move into
217 ;; a register, so we can't conditionally move into the TLS and
218 ;; conditionally move in the opposite flag sense to the symbol.
219 (compute-virtual-symbol)
220 (inst mov
(access-value-slot cell
) value
)))
222 ;; With Symbol-Value, we check that the value isn't the trap object. So
223 ;; Symbol-Value of NIL is NIL.
224 (define-vop (symbol-value)
227 (:args
(symbol :scs
(descriptor-reg constant
) :to
(:result
1)))
228 (:temporary
(:sc descriptor-reg
) symbol-reg
)
229 (:results
(value :scs
(descriptor-reg any-reg
)))
231 (:save-p
:compute-only
)
232 (:variant-vars check-boundp
)
236 ((not (sc-is symbol constant
)) ; SYMBOL-VALUE of a random symbol
237 ;; These reads are inextricably data-dependent
238 (inst mov
(reg-in-size symbol-reg
:dword
) (tls-index-of symbol
))
239 (inst mov value
(access-tls-val symbol-reg
:qword
))
240 (setq symbol-reg symbol
))
241 ((wired-tls-symbol-p (tn-value symbol
)) ; e.g. CL:*PRINT-BASE*
242 (inst mov symbol-reg symbol
) ; = MOV Rxx, [RIP-N]
243 (inst mov value
(access-wired-tls-val (tn-value symbol
))))
244 (t ; commonest case: constant-tn for the symbol, not wired tls
245 ;; Same data-dependencies as the non-constant-tn case.
246 (inst mov symbol-reg symbol
) ; = MOV REG, [RIP-N]
247 (inst mov
(reg-in-size value
:dword
) (tls-index-of symbol-reg
))
248 (inst mov value
(access-tls-val value
:qword
))))
249 (unless (and (sc-is symbol constant
)
250 (symbol-always-thread-local-p (tn-value symbol
)))
251 (inst cmp
(reg-in-size value
:dword
) no-tls-value-marker-widetag
)
252 (inst cmov
:e value
(access-value-slot symbol-reg
)))
254 (inst cmp
(reg-in-size value
:dword
) unbound-marker-widetag
)
255 (inst jmp
:e
(generate-error-code vop
'unbound-symbol-error
258 (define-vop (fast-symbol-value symbol-value
)
259 ;; KLUDGE: not really fast, in fact, because we're going to have to
260 ;; do a full lookup of the thread-local area anyway. But half of
261 ;; the meaning of FAST-SYMBOL-VALUE is "do not signal an error if
262 ;; unbound", which is used in the implementation of COPY-SYMBOL. --
268 ;; SYMBOL-VALUE of a static symbol with a wired TLS index does not
269 ;; load the symbol except in the case of error, and uses no temp either.
270 ;; There's no way to express the lack of encumbrances in the general vop.
271 (define-vop (symeval/static-wired
)
274 ;; The predicates are orthogonal. Symbols can satisfy one, the other,
275 ;; both, or neither. This vop applies only if both.
276 (:arg-types
(:constant
(and (satisfies static-symbol-p
)
277 (satisfies wired-tls-symbol-p
))))
279 (:results
(value :scs
(descriptor-reg any-reg
)))
281 (:save-p
:compute-only
)
282 (:variant-vars check-boundp
)
285 (inst mov value
(access-wired-tls-val symbol
))
286 (unless (symbol-always-thread-local-p symbol
)
287 (inst cmp
(reg-in-size value
:dword
) no-tls-value-marker-widetag
)
288 (inst cmov
:e value
(static-symbol-value-ea symbol
)))
290 (let ((err-label (gen-label)))
291 (assemble (*elsewhere
*)
292 (emit-label err-label
)
293 (inst mov value
(+ nil-value
(static-symbol-offset symbol
)))
294 (emit-error-break vop error-trap
295 (error-number-or-lose 'unbound-symbol-error
)
297 (inst cmp
(reg-in-size value
:dword
) unbound-marker-widetag
)
298 (inst jmp
:e err-label
)))))
300 (define-vop (fast-symeval/static-wired symeval
/static-wired
)
305 ;; Would it be worthwhile to make a static/wired boundp vop?
309 (:args
(object :scs
(descriptor-reg)))
311 (:temporary
(:sc dword-reg
) temp
)
313 (inst mov temp
(tls-index-of object
))
314 (inst mov temp
(access-tls-val temp
:dword
))
315 (inst cmp temp no-tls-value-marker-widetag
)
316 (inst cmov
:e temp
(access-value-slot object
:dword
))
317 (inst cmp temp unbound-marker-widetag
))))
323 (define-vop (symbol-value symbol-global-value
)
324 (:translate symeval
))
325 (define-vop (fast-symbol-value fast-symbol-global-value
)
326 (:translate symeval
))
327 (define-vop (set %set-symbol-global-value
))
331 (:args
(symbol :scs
(descriptor-reg)))
334 (inst cmp
(make-ea-for-object-slot-half
335 symbol symbol-value-slot other-pointer-lowtag
)
336 unbound-marker-widetag
))))
338 (define-vop (symbol-hash)
340 (:translate symbol-hash
)
341 (:args
(symbol :scs
(descriptor-reg)))
342 (:results
(res :scs
(any-reg)))
343 (:result-types positive-fixnum
)
345 ;; The symbol-hash slot of NIL holds NIL because it is also the
346 ;; cdr slot, so we have to zero the fixnum tag bit(s) to make sure
347 ;; it is a fixnum. The lowtag selection magic that is required to
348 ;; ensure this is explained in the comment in objdef.lisp
349 (loadw res symbol symbol-hash-slot other-pointer-lowtag
)
350 (inst and res
(lognot fixnum-tag-mask
))))
352 ;;;; fdefinition (FDEFN) objects
354 (define-vop (fdefn-fun cell-ref
) ; /pfw - alpha
355 (:variant fdefn-fun-slot other-pointer-lowtag
))
357 (define-vop (safe-fdefn-fun)
358 (:translate safe-fdefn-fun
)
360 (:args
(object :scs
(descriptor-reg) :to
(:result
1)))
361 (:results
(value :scs
(descriptor-reg any-reg
)))
363 (:save-p
:compute-only
)
365 (loadw value object fdefn-fun-slot other-pointer-lowtag
)
366 ;; byte comparison works because lowtags of function and nil differ
367 (inst cmp
(reg-in-size value
:byte
) (logand nil-value
#xff
))
368 (let* ((*location-context
* (make-restart-location RETRY value
))
369 (err-lab (generate-error-code vop
'undefined-fun-error object
)))
370 (inst jmp
:e err-lab
))
374 (define-vop (set-fdefn-fun)
376 (:translate
(setf fdefn-fun
))
377 (:args
(function :scs
(descriptor-reg) :target result
)
378 (fdefn :scs
(descriptor-reg)))
379 (:temporary
(:sc unsigned-reg
) raw
)
380 (:temporary
(:sc unsigned-reg
) type
)
381 (:results
(result :scs
(descriptor-reg)))
383 (load-type type function
(- fun-pointer-lowtag
))
385 (make-ea :byte
:base function
386 :disp
(- (* simple-fun-code-offset n-word-bytes
)
387 fun-pointer-lowtag
)))
388 (inst cmp
(reg-in-size type
:byte
) simple-fun-widetag
)
389 (inst jmp
:e NORMAL-FUN
)
390 (inst mov raw
(make-fixup 'closure-tramp
:assembly-routine
))
392 (storew function fdefn fdefn-fun-slot other-pointer-lowtag
)
393 (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
394 (move result function
)))
396 (define-vop (fdefn-makunbound)
398 (:translate fdefn-makunbound
)
399 (:args
(fdefn :scs
(descriptor-reg) :target result
))
400 (:results
(result :scs
(descriptor-reg)))
401 #!+immobile-code
(:temporary
(:sc unsigned-reg
) temp
)
405 (inst mov
(reg-in-size temp
:dword
)
406 (make-fixup 'undefined-tramp
:assembly-routine
))
407 ;; Compute displacement from the call site
408 (inst sub
(reg-in-size temp
:dword
) (reg-in-size fdefn
:dword
))
409 (inst sub
(reg-in-size temp
:dword
)
410 (+ (- other-pointer-lowtag
) (ash fdefn-raw-addr-slot word-shift
) 5))
411 ;; Compute the encoding of a "CALL rel32" instruction
413 (inst or
(reg-in-size temp
:byte
) #xE8
)
415 (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag
)
416 (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag
))
419 (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag
)
420 (storew (make-fixup 'undefined-tramp
:assembly-routine
)
421 fdefn fdefn-raw-addr-slot other-pointer-lowtag
))
422 (move result fdefn
)))
424 ;;;; binding and unbinding
426 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
427 ;;; the symbol on the binding stack and stuff the new value into the
429 ;;; See the "Chapter 9: Specials" of the SBCL Internals Manual.
433 (define-vop (dynbind) ; bind a symbol in a PROGV form
434 (:args
(val :scs
(any-reg descriptor-reg
))
435 (symbol :scs
(descriptor-reg)))
436 (:temporary
(:sc unsigned-reg
:offset rax-offset
) tls-index
)
437 (:temporary
(:sc unsigned-reg
) bsp tmp
)
440 (load-binding-stack-pointer bsp
)
441 (inst mov
(reg-in-size tls-index
:dword
) (tls-index-of symbol
))
442 (inst add bsp
(* binding-size n-word-bytes
))
443 (store-binding-stack-pointer bsp
)
444 (inst test
(reg-in-size tls-index
:dword
) (reg-in-size tls-index
:dword
))
445 (inst jmp
:ne TLS-INDEX-VALID
)
446 (inst mov tls-index symbol
)
447 (invoke-asm-routine 'call
'alloc-tls-index vop tmp
)
449 (inst mov tmp
(make-ea :qword
:base thread-base-tn
:index tls-index
))
450 (storew tmp bsp
(- binding-value-slot binding-size
))
451 (storew tls-index bsp
(- binding-symbol-slot binding-size
))
452 (inst mov
(make-ea :qword
:base thread-base-tn
:index tls-index
) val
)))
454 (define-vop (bind) ; bind a known symbol
455 (:args
(val :scs
(any-reg descriptor-reg
)))
456 (:temporary
(:sc unsigned-reg
) bsp tmp
)
459 (inst mov bsp
(* binding-size n-word-bytes
))
461 (make-ea :qword
:base thread-base-tn
462 :disp
(ash thread-binding-stack-pointer-slot word-shift
))
464 (let* ((tls-index (load-time-tls-offset symbol
))
465 (tls-cell (make-ea :qword
:base thread-base-tn
:disp tls-index
)))
466 ;; Too bad we can't use "XCHG [r12+disp], val" to write the new value
467 ;; and read the old value in one step. It will violate the constraints
468 ;; prescribed in the internal documentation on special binding.
469 (inst mov tmp tls-cell
)
470 (storew tmp bsp binding-value-slot
)
471 ;; Indices are small enough to be written as :DWORDs which avoids
472 ;; a REX prefix if 'bsp' happens to be any of the low 8 registers.
473 (inst mov
(make-ea :dword
:base bsp
474 :disp
(ash binding-symbol-slot word-shift
)) tls-index
)
475 (inst mov tls-cell val
)))))
478 (define-vop (dynbind)
479 (:args
(val :scs
(any-reg descriptor-reg
))
480 (symbol :scs
(descriptor-reg)))
481 (:temporary
(:sc unsigned-reg
) temp bsp
)
483 (load-symbol-value bsp
*binding-stack-pointer
*)
484 (loadw temp symbol symbol-value-slot other-pointer-lowtag
)
485 (inst add bsp
(* binding-size n-word-bytes
))
486 (store-symbol-value bsp
*binding-stack-pointer
*)
487 (storew temp bsp
(- binding-value-slot binding-size
))
488 (storew symbol bsp
(- binding-symbol-slot binding-size
))
489 (storew val symbol symbol-value-slot other-pointer-lowtag
)))
493 (:temporary
(:sc unsigned-reg
) temp bsp tls-index
)
494 (:temporary
(:sc complex-double-reg
) zero
)
497 (load-binding-stack-pointer bsp
)
498 (inst xorpd zero zero
)
501 (inst sub bsp
(* binding-size n-word-bytes
))
502 ;; Load TLS-INDEX of the SYMBOL from stack
503 (inst mov
(reg-in-size tls-index
:dword
)
504 (make-ea :dword
:base bsp
:disp
(* binding-symbol-slot n-word-bytes
)))
506 ;; Load VALUE from stack, then restore it to the TLS area.
507 (loadw temp bsp binding-value-slot
)
508 (inst mov
(make-ea :qword
:base thread-base-tn
:index tls-index
)
510 ;; Zero out the stack.
511 (inst movapd
(make-ea :qword
:base bsp
) zero
))
512 (store-binding-stack-pointer bsp
)))
516 (:temporary
(:sc unsigned-reg
) symbol value bsp
)
518 (load-symbol-value bsp
*binding-stack-pointer
*)
519 (loadw symbol bsp
(- binding-symbol-slot binding-size
))
520 (loadw value bsp
(- binding-value-slot binding-size
))
521 (storew value symbol symbol-value-slot other-pointer-lowtag
)
522 (storew 0 bsp
(- binding-symbol-slot binding-size
))
523 (storew 0 bsp
(- binding-value-slot binding-size
))
524 (inst sub bsp
(* binding-size n-word-bytes
))
525 (store-symbol-value bsp
*binding-stack-pointer
*)))
527 (define-vop (unbind-to-here)
528 (:args
(where :scs
(descriptor-reg any-reg
)))
529 (:temporary
(:sc unsigned-reg
) symbol value bsp
)
530 (:temporary
(:sc complex-double-reg
) zero
)
532 (load-binding-stack-pointer bsp
)
535 (inst xorpd zero zero
)
537 (inst sub bsp
(* binding-size n-word-bytes
))
538 ;; on sb-thread symbol is actually a tls-index, and it fits into
541 (let ((tls-index (reg-in-size symbol
:dword
)))
543 (make-ea :dword
:base bsp
:disp
(* binding-symbol-slot n-word-bytes
)))
544 (inst test tls-index tls-index
))
547 (loadw symbol bsp binding-symbol-slot
)
548 (inst test symbol symbol
))
550 (loadw value bsp binding-value-slot
)
552 (storew value symbol symbol-value-slot other-pointer-lowtag
)
554 (inst mov
(make-ea :qword
:base thread-base-tn
:index symbol
)
558 (inst movapd
(make-ea :qword
:base bsp
) zero
)
562 (store-binding-stack-pointer bsp
)
566 ;;;; closure indexing
568 (define-full-reffer closure-index-ref
*
569 closure-info-offset fun-pointer-lowtag
570 (any-reg descriptor-reg
) * %closure-index-ref
)
572 (define-full-setter set-funcallable-instance-info
*
573 funcallable-instance-info-offset fun-pointer-lowtag
574 (any-reg descriptor-reg
) * %set-funcallable-instance-info
)
576 (define-full-reffer funcallable-instance-info
*
577 funcallable-instance-info-offset fun-pointer-lowtag
578 (descriptor-reg any-reg
) * %funcallable-instance-info
)
580 (define-vop (closure-ref slot-ref
)
581 (:variant closure-info-offset fun-pointer-lowtag
))
583 (define-vop (closure-init slot-set
)
584 (:variant closure-info-offset fun-pointer-lowtag
))
586 (define-vop (closure-init-from-fp)
587 (:args
(object :scs
(descriptor-reg)))
590 (storew rbp-tn object
(+ closure-info-offset offset
) fun-pointer-lowtag
)))
592 ;;;; value cell hackery
594 (define-vop (value-cell-ref cell-ref
)
595 (:variant value-cell-value-slot other-pointer-lowtag
))
597 (define-vop (value-cell-set cell-set
)
598 (:variant value-cell-value-slot other-pointer-lowtag
))
600 ;;;; structure hackery
602 (define-vop (instance-length)
604 (:translate %instance-length
)
605 (:args
(struct :scs
(descriptor-reg)))
606 (:results
(res :scs
(unsigned-reg)))
607 (:result-types positive-fixnum
)
609 (inst mov
(reg-in-size res
:word
)
610 (make-ea :word
:base struct
611 :disp
(1+ (- instance-pointer-lowtag
))))
612 (inst movzx
(reg-in-size res
:dword
) (reg-in-size res
:word
))))
614 #!+compact-instance-header
616 (define-vop (%instance-layout
)
617 (:translate %instance-layout
)
619 (:args
(object :scs
(descriptor-reg)))
620 (:results
(res :scs
(descriptor-reg)))
621 (:variant-vars lowtag
)
622 (:variant instance-pointer-lowtag
)
624 (inst mov
(reg-in-size res
:dword
) (make-ea :dword
:base object
:disp
(- 4 lowtag
)))))
625 (define-vop (%set-instance-layout
)
626 (:translate %set-instance-layout
)
628 (:args
(object :scs
(descriptor-reg))
629 (value :scs
(any-reg descriptor-reg
) :target res
))
630 (:results
(res :scs
(any-reg descriptor-reg
)))
631 (:variant-vars lowtag
)
632 (:variant instance-pointer-lowtag
)
634 (inst mov
(make-ea :dword
:base object
:disp
(- 4 lowtag
)) (reg-in-size value
:dword
))
636 (define-vop (%funcallable-instance-layout %instance-layout
)
637 (:translate %funcallable-instance-layout
)
638 (:variant fun-pointer-lowtag
))
639 (define-vop (%set-funcallable-instance-layout %set-instance-layout
)
640 (:translate %set-funcallable-instance-layout
)
641 (:variant fun-pointer-lowtag
)))
643 (define-full-reffer instance-index-ref
* instance-slots-offset
644 instance-pointer-lowtag
(any-reg descriptor-reg
) * %instance-ref
)
646 (define-full-setter instance-index-set
* instance-slots-offset
647 instance-pointer-lowtag
(any-reg descriptor-reg
) * %instance-set
)
649 (define-full-compare-and-swap %instance-cas instance
650 instance-slots-offset instance-pointer-lowtag
651 (any-reg descriptor-reg
) * %instance-cas
)
652 (define-full-compare-and-swap %raw-instance-cas
/word instance
653 instance-slots-offset instance-pointer-lowtag
654 (unsigned-reg) unsigned-num %raw-instance-cas
/word
)
656 ;;;; code object frobbing
658 (define-full-reffer code-header-ref
* 0 other-pointer-lowtag
659 (any-reg descriptor-reg
) * code-header-ref
)
661 (define-full-setter code-header-set
* 0 other-pointer-lowtag
662 (any-reg descriptor-reg
) * code-header-set
)
664 ;;;; raw instance slot accessors
666 (flet ((make-ea-for-raw-slot (object index
)
671 :disp
(+ (* (+ instance-slots-offset index
) n-word-bytes
)
672 (- instance-pointer-lowtag
))))
677 :scale
(ash 1 (- word-shift n-fixnum-tag-bits
))
678 :disp
(+ (* instance-slots-offset n-word-bytes
)
679 (- instance-pointer-lowtag
)))))))
681 ((def (suffix result-sc result-type inst
&optional
(inst/c inst
))
683 (define-vop (,(symbolicate "RAW-INSTANCE-REF/" suffix
))
684 (:translate
,(symbolicate "%RAW-INSTANCE-REF/" suffix
))
686 (:args
(object :scs
(descriptor-reg)) (index :scs
(any-reg)))
687 (:arg-types
* tagged-num
)
688 (:results
(value :scs
(,result-sc
)))
689 (:result-types
,result-type
)
691 (inst ,inst value
(make-ea-for-raw-slot object index
))))
692 (define-vop (,(symbolicate "RAW-INSTANCE-REF-C/" suffix
))
693 (:translate
,(symbolicate "%RAW-INSTANCE-REF/" suffix
))
695 (:args
(object :scs
(descriptor-reg)))
696 ;; Why are we pedantic about the index constraint here
697 ;; if we're not equally so in the init vop?
698 (:arg-types
* (:constant
(load/store-index
#.n-word-bytes
699 #.instance-pointer-lowtag
700 #.instance-slots-offset
)))
702 (:results
(value :scs
(,result-sc
)))
703 (:result-types
,result-type
)
705 (inst ,inst
/c value
(make-ea-for-raw-slot object index
))))
706 (define-vop (,(symbolicate "RAW-INSTANCE-SET/" suffix
))
707 (:translate
,(symbolicate "%RAW-INSTANCE-SET/" suffix
))
709 (:args
(object :scs
(descriptor-reg))
710 (index :scs
(any-reg))
711 (value :scs
(,result-sc
) :target result
))
712 (:arg-types
* tagged-num
,result-type
)
713 (:results
(result :scs
(,result-sc
)))
714 (:result-types
,result-type
)
716 (inst ,inst
(make-ea-for-raw-slot object index
) value
)
717 (move result value
)))
718 (define-vop (,(symbolicate "RAW-INSTANCE-SET-C/" suffix
))
719 (:translate
,(symbolicate "%RAW-INSTANCE-SET/" suffix
))
721 (:args
(object :scs
(descriptor-reg))
722 (value :scs
(,result-sc
) :target result
))
723 (:arg-types
* (:constant
(load/store-index
#.n-word-bytes
724 #.instance-pointer-lowtag
725 #.instance-slots-offset
))
728 (:results
(result :scs
(,result-sc
)))
729 (:result-types
,result-type
)
731 (inst ,inst
/c
(make-ea-for-raw-slot object index
) value
)
732 (move result value
)))
733 (define-vop (,(symbolicate "RAW-INSTANCE-INIT/" suffix
))
734 (:args
(object :scs
(descriptor-reg))
735 (value :scs
(,result-sc
)))
736 (:arg-types
* ,result-type
)
739 (inst ,inst
/c
(make-ea-for-raw-slot object index
) value
))))))
740 (def word unsigned-reg unsigned-num mov
)
741 (def signed-word signed-reg signed-num mov
)
742 (def single single-reg single-float movss
)
743 (def double double-reg double-float movsd
)
744 (def complex-single complex-single-reg complex-single-float movq
)
745 (def complex-double complex-double-reg complex-double-float
746 movupd
(if (oddp index
) 'movapd
'movupd
)))
748 (define-vop (raw-instance-atomic-incf/word
)
749 (:translate %raw-instance-atomic-incf
/word
)
751 (:args
(object :scs
(descriptor-reg))
752 (index :scs
(any-reg))
753 (diff :scs
(unsigned-reg) :target result
))
754 (:arg-types
* tagged-num unsigned-num
)
755 (:results
(result :scs
(unsigned-reg)))
756 (:result-types unsigned-num
)
758 (inst xadd
(make-ea-for-raw-slot object index
) diff
:lock
)
761 (define-vop (raw-instance-atomic-incf-c/word
)
762 (:translate %raw-instance-atomic-incf
/word
)
764 (:args
(object :scs
(descriptor-reg))
765 (diff :scs
(unsigned-reg) :target result
))
766 (:arg-types
* (:constant
(load/store-index
#.n-word-bytes
767 #.instance-pointer-lowtag
768 #.instance-slots-offset
))
771 (:results
(result :scs
(unsigned-reg)))
772 (:result-types unsigned-num
)
774 (inst xadd
(make-ea-for-raw-slot object index
) diff
:lock
)
775 (move result diff
))))