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 null
)))
28 (:info name offset lowtag
)
32 (storew value object offset lowtag
)))
34 (define-vop (init-slot set-slot
)
35 (:info name dx-p offset lowtag
)
38 (define-vop (compare-and-swap-slot)
39 (:args
(object :scs
(descriptor-reg))
40 (old :scs
(descriptor-reg any-reg
))
41 (new :scs
(descriptor-reg any-reg
)))
42 (:info name offset lowtag
)
44 (:temporary
(:sc interior-reg
) lip
)
45 (:results
(result :scs
(descriptor-reg any-reg
) :from
:load
))
48 (inst add-sub lip object
(- (* offset n-word-bytes
) lowtag
))
50 (inst ldxr result lip
)
53 (inst stlxr tmp-tn new lip
)
54 (inst cbnz tmp-tn LOOP
)
59 ;;;; Symbol hacking VOPs:
61 ;;; Do a cell ref with an error check for being unbound.
63 (define-vop (checked-cell-ref)
64 (:args
(object :scs
(descriptor-reg) :to
:save
))
65 (:results
(value :scs
(descriptor-reg any-reg
)))
68 (:save-p
:compute-only
))
69 ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound.
70 (define-vop (boundp-frob)
71 (:args
(object :scs
(descriptor-reg)))
75 (:temporary
(:scs
(descriptor-reg)) value
))
77 ;;; With Symbol-Value, we check that the value isn't the trap object. So
78 ;;; Symbol-Value of NIL is NIL.
82 (:args
(object :scs
(descriptor-reg))
83 (value :scs
(descriptor-reg any-reg null
)))
84 (:temporary
(:sc any-reg
) tls-index
)
86 (inst ldr
(32-bit-reg tls-index
) (tls-index-of object
))
87 (inst ldr tmp-tn
(@ thread-tn tls-index
))
88 (inst cmp tmp-tn no-tls-value-marker-widetag
)
90 (storew value object symbol-value-slot other-pointer-lowtag
)
93 (inst str value
(@ thread-tn tls-index
))
96 (define-vop (symbol-value checked-cell-ref
)
98 (:temporary
(:sc any-reg
) tls-index
)
99 (:variant-vars check-boundp
)
102 (inst ldr
(32-bit-reg tls-index
) (tls-index-of object
))
103 (inst ldr value
(@ thread-tn tls-index
))
104 (inst cmp value no-tls-value-marker-widetag
)
106 (loadw value object symbol-value-slot other-pointer-lowtag
)
109 (let ((err-lab (generate-error-code vop
'unbound-symbol-error object
)))
110 (inst cmp value unbound-marker-widetag
)
111 (inst b
:eq err-lab
)))))
113 (define-vop (fast-symbol-value symbol-value
)
118 (define-vop (boundp boundp-frob
)
120 (:temporary
(:sc any-reg
) tls-index
)
122 (inst ldr
(32-bit-reg tls-index
) (tls-index-of object
))
123 (inst ldr value
(@ thread-tn tls-index
))
124 (inst cmp value no-tls-value-marker-widetag
)
126 (loadw value object symbol-value-slot other-pointer-lowtag
)
128 (inst cmp value unbound-marker-widetag
)
129 (inst b
(if not-p
:eq
:ne
) target
))))
133 (define-vop (set cell-set
)
134 (:variant symbol-value-slot other-pointer-lowtag
))
135 (define-vop (symbol-value checked-cell-ref
)
138 (loadw value object symbol-value-slot other-pointer-lowtag
)
139 (let ((err-lab (generate-error-code vop
'unbound-symbol-error object
)))
140 (inst cmp value unbound-marker-widetag
)
141 (inst b
:eq err-lab
))))
142 (define-vop (fast-symbol-value cell-ref
)
143 (:variant symbol-value-slot other-pointer-lowtag
)
145 (:translate symeval
))
147 (define-vop (boundp boundp-frob
)
150 (loadw value object symbol-value-slot other-pointer-lowtag
)
151 (inst cmp value unbound-marker-widetag
)
152 (inst b
(if not-p
:eq
:ne
) target
))))
154 (define-vop (%set-symbol-global-value cell-set
)
155 (:variant symbol-value-slot other-pointer-lowtag
))
157 (define-vop (fast-symbol-global-value cell-ref
)
158 (:variant symbol-value-slot other-pointer-lowtag
)
160 (:translate sym-global-val
))
162 (define-vop (symbol-global-value)
164 (:translate sym-global-val
)
165 (:args
(object :scs
(descriptor-reg) :to
(:result
1)))
166 (:results
(value :scs
(descriptor-reg any-reg
)))
168 (:save-p
:compute-only
)
170 (let ((err-lab (generate-error-code vop
'unbound-symbol-error object
)))
171 (loadw value object symbol-value-slot other-pointer-lowtag
)
172 (inst cmp value unbound-marker-widetag
)
173 (inst b
:eq err-lab
))))
175 (define-vop (symbol-hash)
177 (:translate symbol-hash
)
178 (:args
(symbol :scs
(descriptor-reg)))
179 (:temporary
(:scs
(non-descriptor-reg)) temp
)
180 (:results
(res :scs
(any-reg)))
181 (:result-types positive-fixnum
)
183 ;; The symbol-hash slot of NIL holds NIL because it is also the
184 ;; cdr slot, so we have to strip off the two low bits to make sure
185 ;; it is a fixnum. The lowtag selection magic that is required to
186 ;; ensure this is explained in the comment in objdef.lisp
187 (loadw temp symbol symbol-hash-slot other-pointer-lowtag
)
188 (inst and res temp
(bic-mask fixnum-tag-mask
))))
190 (define-vop (%compare-and-swap-symbol-value
)
191 (:translate %compare-and-swap-symbol-value
)
192 (:args
(symbol :scs
(descriptor-reg))
193 (old :scs
(descriptor-reg any-reg
))
194 (new :scs
(descriptor-reg any-reg
)))
195 (:results
(result :scs
(descriptor-reg any-reg
) :from
:load
))
197 (:temporary
(:sc any-reg
) tls-index
)
198 (:temporary
(:sc interior-reg
) lip
)
205 (inst ldr
(32-bit-reg tls-index
) (tls-index-of symbol
))
206 ;; Thread-local area, no synchronization needed.
207 (inst ldr result
(@ thread-tn tls-index
))
208 (inst cmp result old
)
209 (inst b
:ne DONT-STORE-TLS
)
210 (inst str new
(@ thread-tn tls-index
))
213 (inst cmp result no-tls-value-marker-widetag
)
214 (inst b
:ne CHECK-UNBOUND
))
215 (inst add-sub lip symbol
(- (* symbol-value-slot n-word-bytes
)
216 other-pointer-lowtag
))
218 (inst ldxr result lip
)
219 (inst cmp result old
)
221 (inst stlxr tmp-tn new lip
)
222 (inst cbnz tmp-tn LOOP
)
229 (inst cmp result unbound-marker-widetag
)
230 (inst b
:eq
(generate-error-code vop
'unbound-symbol-error symbol
))))
232 ;;;; Fdefinition (fdefn) objects.
234 (define-vop (fdefn-fun cell-ref
)
235 (:variant fdefn-fun-slot other-pointer-lowtag
))
237 (define-vop (safe-fdefn-fun)
238 (:translate safe-fdefn-fun
)
240 (:args
(object :scs
(descriptor-reg) :to
:save
))
241 (:results
(value :scs
(descriptor-reg any-reg
)))
243 (:save-p
:compute-only
)
245 (loadw value object fdefn-fun-slot other-pointer-lowtag
)
246 (inst cmp value null-tn
)
248 (let ((*location-context
* (make-restart-location RETRY value
)))
249 (generate-error-code vop
'undefined-fun-error object
)))
252 (define-vop (set-fdefn-fun)
254 (:translate
(setf fdefn-fun
))
255 (:args
(function :scs
(descriptor-reg) :target result
)
256 (fdefn :scs
(descriptor-reg)))
257 (:temporary
(:scs
(interior-reg)) lip
)
258 (:temporary
(:scs
(non-descriptor-reg)) type
)
259 (:results
(result :scs
(descriptor-reg)))
261 (inst add-sub lip function
(- (* simple-fun-code-offset n-word-bytes
)
263 (load-type type function
(- fun-pointer-lowtag
))
264 (inst cmp type simple-fun-widetag
)
265 (inst b
:eq SIMPLE-FUN
)
266 (load-inline-constant lip
'(:fixup closure-tramp
:assembly-routine
) lip
)
268 (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
269 (storew function fdefn fdefn-fun-slot other-pointer-lowtag
)
270 (move result function
)))
272 (define-vop (fdefn-makunbound)
274 (:translate fdefn-makunbound
)
275 (:args
(fdefn :scs
(descriptor-reg) :target result
))
276 (:temporary
(:scs
(non-descriptor-reg)) temp
)
277 (:temporary
(:scs
(interior-reg)) lip
)
278 (:results
(result :scs
(descriptor-reg)))
280 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag
)
281 (load-inline-constant temp
'(:fixup undefined-tramp
:assembly-routine
) lip
)
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
294 (define-vop (dynbind)
295 (:args
(value :scs
(any-reg descriptor-reg
) :to
:save
)
296 (symbol :scs
(descriptor-reg)))
297 (:temporary
(:sc descriptor-reg
) value-temp
)
298 (:temporary
(:sc descriptor-reg
:offset r0-offset
:from
(:argument
1)) alloc-tls-symbol
)
299 (:temporary
(:sc non-descriptor-reg
:offset nl0-offset
) tls-index
)
300 (:temporary
(:sc non-descriptor-reg
:offset nl1-offset
) free-tls-index
)
301 (:temporary
(:sc interior-reg
) lip
)
302 (:ignore free-tls-index
)
303 (:temporary
(:scs
(any-reg)) bsp
)
305 (load-binding-stack-pointer bsp
)
306 (inst ldr
(32-bit-reg tls-index
) (tls-index-of symbol
))
307 (inst add bsp bsp
(* binding-size n-word-bytes
))
308 (store-binding-stack-pointer bsp
)
309 (inst cbnz
(32-bit-reg tls-index
) TLS-INDEX-VALID
)
310 (move alloc-tls-symbol symbol
)
311 (load-inline-constant value-temp
'(:fixup alloc-tls-index
:assembly-routine
) lip
)
312 (inst blr value-temp
)
315 (inst ldr value-temp
(@ thread-tn tls-index
))
316 (inst stp value-temp tls-index
(@ bsp
(* (- binding-value-slot binding-size
)
318 (inst str value
(@ thread-tn tls-index
))))
322 (:temporary
(:sc descriptor-reg
) value
)
323 (:temporary
(:sc any-reg
) tls-index bsp
)
325 (load-binding-stack-pointer bsp
)
328 (inst ldp value tls-index
(@ bsp
(* (- binding-value-slot binding-size
)
330 (inst str value
(@ thread-tn tls-index
))
332 ;; The order of stores here is reversed with respect to interrupt safety,
333 ;; but STP cannot be interrupted in the middle.
334 (inst stp zr-tn zr-tn
(@ bsp
(* (- binding-value-slot binding-size
)
337 (store-binding-stack-pointer bsp
))))
339 (define-vop (unbind-to-here)
340 (:args
(arg :scs
(descriptor-reg any-reg
) :target where
))
341 (:temporary
(:scs
(any-reg) :from
(:argument
0)) where
)
342 (:temporary
(:scs
(descriptor-reg)) symbol value
)
343 (:temporary
(:scs
(any-reg)) bsp
)
345 (load-binding-stack-pointer bsp
)
351 ;; on sb-thread SYMBOL is actually a tls-index
352 (inst ldp value symbol
(@ bsp
(* (- binding-value-slot binding-size
)
354 (inst cbz symbol ZERO
)
356 (storew value symbol symbol-value-slot other-pointer-lowtag
)
358 (inst str value
(@ thread-tn symbol
))
360 (inst stp zr-tn zr-tn
(@ bsp
(* (- binding-value-slot binding-size
)
368 (store-binding-stack-pointer bsp
)))
371 (define-vop (dynbind)
372 (:args
(val :scs
(any-reg descriptor-reg
))
373 (symbol :scs
(descriptor-reg)))
374 (:temporary
(:scs
(descriptor-reg)) value-temp
)
375 (:temporary
(:scs
(any-reg)) bsp-temp
)
377 (loadw value-temp symbol symbol-value-slot other-pointer-lowtag
)
378 (load-symbol-value bsp-temp
*binding-stack-pointer
*)
379 (inst add bsp-temp bsp-temp
(* binding-size n-word-bytes
))
380 (store-symbol-value bsp-temp
*binding-stack-pointer
*)
381 (inst stp value-temp symbol
(@ bsp-temp
(* (- binding-value-slot binding-size
) n-word-bytes
)))
382 (storew val symbol symbol-value-slot other-pointer-lowtag
)))
385 (:temporary
(:scs
(descriptor-reg)) symbol value
)
386 (:temporary
(:scs
(any-reg)) bsp-temp
)
388 (load-symbol-value bsp-temp
*binding-stack-pointer
*)
389 (inst ldp value symbol
(@ bsp-temp
(* (- binding-value-slot binding-size
)
391 (storew value symbol symbol-value-slot other-pointer-lowtag
)
392 ;; The order of stores here is reversed with respect to interrupt safety,
393 ;; but STP cannot be interrupted in the middle.
394 (inst stp zr-tn zr-tn
(@ bsp-temp
(* (- binding-value-slot binding-size
)
397 (store-symbol-value bsp-temp
*binding-stack-pointer
*))))
399 ;;;; Closure indexing.
401 (define-full-reffer closure-index-ref
*
402 closure-info-offset fun-pointer-lowtag
403 (descriptor-reg any-reg
) * %closure-index-ref
)
405 (define-full-setter set-funcallable-instance-info
*
406 funcallable-instance-info-offset fun-pointer-lowtag
407 (descriptor-reg any-reg null
) * %set-funcallable-instance-info
)
409 (define-full-reffer funcallable-instance-info
*
410 funcallable-instance-info-offset fun-pointer-lowtag
411 (descriptor-reg any-reg
) * %funcallable-instance-info
)
413 (define-vop (closure-ref slot-ref
)
414 (:variant closure-info-offset fun-pointer-lowtag
))
416 (define-vop (closure-init slot-set
)
417 (:variant closure-info-offset fun-pointer-lowtag
))
419 (define-vop (closure-init-from-fp)
420 (:args
(object :scs
(descriptor-reg)))
423 (storew cfp-tn object
(+ closure-info-offset offset
) fun-pointer-lowtag
)))
425 ;;;; Value Cell hackery.
427 (define-vop (value-cell-ref cell-ref
)
428 (:variant value-cell-value-slot other-pointer-lowtag
))
430 (define-vop (value-cell-set cell-set
)
431 (:variant value-cell-value-slot other-pointer-lowtag
))
433 ;;;; Instance hackery:
435 (define-vop (instance-length)
437 (:translate %instance-length
)
438 (:args
(struct :scs
(descriptor-reg)))
439 (:temporary
(:scs
(non-descriptor-reg)) temp
)
440 (:results
(res :scs
(unsigned-reg)))
441 (:result-types positive-fixnum
)
443 (loadw temp struct
0 instance-pointer-lowtag
)
444 (inst lsr res temp n-widetag-bits
)))
446 (define-full-reffer instance-index-ref
* instance-slots-offset
447 instance-pointer-lowtag
(descriptor-reg any-reg
) * %instance-ref
)
449 (define-full-setter instance-index-set
* instance-slots-offset
450 instance-pointer-lowtag
(descriptor-reg any-reg null
) * %instance-set
)
452 (define-vop (%instance-cas word-index-cas
)
454 (:translate %instance-cas
)
455 (:variant instance-slots-offset instance-pointer-lowtag
)
456 (:arg-types instance tagged-num
* *))
458 ;;;; Code object frobbing.
460 (define-full-reffer code-header-ref
* 0 other-pointer-lowtag
461 (descriptor-reg any-reg
) * code-header-ref
)
463 (define-full-setter code-header-set
* 0 other-pointer-lowtag
464 (descriptor-reg any-reg null
) * code-header-set
)
466 ;;;; raw instance slot accessors
469 ((define-raw-slot-vops (name value-primtype value-sc
470 &optional
(move-macro 'move
))
471 (labels ((emit-generator (instruction move-result
)
474 (inst ,instruction value
476 (load-store-offset (- (* (+ instance-slots-offset
479 instance-pointer-lowtag
)))))
481 (inst lsl offset index
(- word-shift n-fixnum-tag-bits
))
482 (inst add offset offset
(- (* instance-slots-offset
484 instance-pointer-lowtag
))
485 (inst ,instruction value
(@ object offset
))))
487 `((,move-macro result value
))))))
488 (let ((ref-vop (symbolicate "RAW-INSTANCE-REF/" name
))
489 (set-vop (symbolicate "RAW-INSTANCE-SET/" name
)))
491 (define-vop (,ref-vop
)
492 (:translate
,(symbolicate "%" ref-vop
))
494 (:args
(object :scs
(descriptor-reg))
495 (index :scs
(any-reg immediate
)))
496 (:arg-types
* positive-fixnum
)
497 (:results
(value :scs
(,value-sc
)))
498 (:result-types
,value-primtype
)
499 (:temporary
(:scs
(non-descriptor-reg)) offset
)
500 (:generator
5 ,@(emit-generator 'ldr nil
)))
501 (define-vop (,set-vop
)
502 (:translate
,(symbolicate "%" set-vop
))
504 (:args
(object :scs
(descriptor-reg))
505 (index :scs
(any-reg immediate
))
506 (value :scs
(,value-sc
) :target result
))
507 (:arg-types
* positive-fixnum
,value-primtype
)
508 (:results
(result :scs
(,value-sc
)))
509 (:result-types
,value-primtype
)
510 (:temporary
(:scs
(non-descriptor-reg)) offset
)
511 (:generator
5 ,@(emit-generator 'str t
))))))))
512 (define-raw-slot-vops word unsigned-num unsigned-reg
)
513 (define-raw-slot-vops signed-word signed-num signed-reg
)
514 (define-raw-slot-vops single single-float single-reg
516 (define-raw-slot-vops double double-float double-reg
518 (define-raw-slot-vops complex-single complex-single-float complex-single-reg
520 (define-raw-slot-vops complex-double complex-double-float complex-double-reg
521 move-complex-double
))
523 (define-vop (raw-instance-atomic-incf/word
)
524 (:translate %raw-instance-atomic-incf
/word
)
526 (:args
(object :scs
(descriptor-reg))
527 (index :scs
(any-reg))
528 (diff :scs
(unsigned-reg)))
529 (:arg-types
* positive-fixnum unsigned-num
)
530 (:temporary
(:sc non-descriptor-reg
) sum
)
531 (:temporary
(:sc interior-reg
) lip
)
532 (:results
(result :scs
(unsigned-reg) :from
:load
))
533 (:result-types unsigned-num
)
535 (inst add lip object
(lsl index
(- word-shift n-fixnum-tag-bits
)))
536 (inst add lip lip
(- (* instance-slots-offset
538 instance-pointer-lowtag
))
542 (inst ldxr result lip
)
543 (inst add sum result diff
)
544 (inst stlxr tmp-tn sum lip
)
545 (inst cbnz tmp-tn LOOP
)