1 ;;;; the VM definition of various primitive memory access VOPs for
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 zero
)))
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 ;;;; Symbol hacking VOPs:
40 ;;; The compiler likes to be able to directly SET symbols.
42 (define-vop (set cell-set
)
43 (:variant symbol-value-slot other-pointer-lowtag
))
45 ;;; Do a cell ref with an error check for being unbound.
47 (define-vop (checked-cell-ref)
48 (:args
(object :scs
(descriptor-reg) :target obj-temp
))
49 (:results
(value :scs
(descriptor-reg any-reg
)))
52 (:save-p
:compute-only
)
53 (:temporary
(:scs
(non-descriptor-reg)) temp
)
54 (:temporary
(:scs
(descriptor-reg) :from
(:argument
0)) obj-temp
))
56 ;;; With Symbol-Value, we check that the value isn't the trap object. So
57 ;;; Symbol-Value of NIL is NIL.
59 (define-vop (symbol-value checked-cell-ref
)
62 (move obj-temp object
)
63 (loadw value obj-temp symbol-value-slot other-pointer-lowtag
)
64 (let ((err-lab (generate-error-code vop
'unbound-symbol-error obj-temp
)))
65 (inst xor temp value unbound-marker-widetag
)
66 (inst beq temp err-lab
)
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
)
76 (:temporary
(:scs
(non-descriptor-reg)) temp
))
78 (define-vop (boundp boundp-frob
)
81 (loadw value object symbol-value-slot other-pointer-lowtag
)
82 (inst xor temp value unbound-marker-widetag
)
84 (inst beq temp target
)
85 (inst bne temp target
))
88 (define-vop (fast-symbol-value cell-ref
)
89 (:variant symbol-value-slot other-pointer-lowtag
)
93 (define-vop (symbol-hash)
95 (:translate symbol-hash
)
96 (:args
(symbol :scs
(descriptor-reg)))
97 (:temporary
(:scs
(non-descriptor-reg)) temp
)
98 (:results
(res :scs
(any-reg)))
99 (:result-types positive-fixnum
)
101 ;; The symbol-hash slot of NIL holds NIL because it is also the
102 ;; cdr slot, so we have to strip off the two low bits to make sure
103 ;; it is a fixnum. The lowtag selection magic that is required to
104 ;; ensure this is explained in the comment in objdef.lisp
105 (loadw temp symbol symbol-hash-slot other-pointer-lowtag
)
106 (inst srl temp n-fixnum-tag-bits
)
107 (inst sll res temp n-fixnum-tag-bits
)))
109 ;;; On unithreaded builds these are just copies of the non-global versions.
110 (define-vop (%set-symbol-global-value set
))
111 (define-vop (symbol-global-value symbol-value
)
112 (:translate sym-global-val
))
113 (define-vop (fast-symbol-global-value fast-symbol-value
)
114 (:translate sym-global-val
))
116 ;;;; Fdefinition (fdefn) objects.
118 (define-vop (fdefn-fun cell-ref
)
119 (:variant fdefn-fun-slot other-pointer-lowtag
))
121 (define-vop (safe-fdefn-fun)
122 (:translate safe-fdefn-fun
)
124 (:args
(object :scs
(descriptor-reg) :target obj-temp
))
125 (:results
(value :scs
(descriptor-reg any-reg
)))
127 (:save-p
:compute-only
)
128 (:temporary
(:scs
(descriptor-reg) :from
(:argument
0)) obj-temp
)
130 (move obj-temp object
)
131 (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag
)
132 (let ((err-lab (generate-error-code vop
'undefined-fun-error obj-temp
)))
133 (inst beq value null-tn err-lab
))
136 (define-vop (set-fdefn-fun)
138 (:translate
(setf fdefn-fun
))
139 (:args
(function :scs
(descriptor-reg) :target result
)
140 (fdefn :scs
(descriptor-reg)))
141 (:temporary
(:scs
(interior-reg)) lip
)
142 (:temporary
(:scs
(non-descriptor-reg)) type
)
143 (:results
(result :scs
(descriptor-reg)))
145 (let ((normal-fn (gen-label)))
146 (load-type type function
(- fun-pointer-lowtag
))
148 (inst xor type simple-fun-widetag
)
149 (inst beq type normal-fn
)
150 (inst addu lip function
151 (- (ash simple-fun-code-offset word-shift
)
153 (inst li lip
(make-fixup 'closure-tramp
:assembly-routine
))
154 (emit-label normal-fn
)
155 (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
156 (storew function fdefn fdefn-fun-slot other-pointer-lowtag
)
157 (move result function
))))
159 (define-vop (fdefn-makunbound)
161 (:translate fdefn-makunbound
)
162 (:args
(fdefn :scs
(descriptor-reg) :target result
))
163 (:temporary
(:scs
(non-descriptor-reg)) temp
)
164 (:results
(result :scs
(descriptor-reg)))
166 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag
)
167 (inst li temp
(make-fixup 'undefined-tramp
:assembly-routine
))
168 (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag
)
169 (move result fdefn
)))
173 ;;;; Binding and Unbinding.
175 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
176 ;;; the symbol on the binding stack and stuff the new value into the
178 ;;; See the "Chapter 9: Specials" of the SBCL Internals Manual.
180 (define-vop (dynbind)
181 (:args
(val :scs
(any-reg descriptor-reg
))
182 (symbol :scs
(descriptor-reg)))
183 (:temporary
(:scs
(descriptor-reg)) temp
)
185 (loadw temp symbol symbol-value-slot other-pointer-lowtag
)
186 (inst addu bsp-tn bsp-tn
(* 2 n-word-bytes
))
187 (storew temp bsp-tn
(- binding-value-slot binding-size
))
188 (storew symbol bsp-tn
(- binding-symbol-slot binding-size
))
189 (storew val symbol symbol-value-slot other-pointer-lowtag
)))
193 (:temporary
(:scs
(descriptor-reg)) symbol value
)
195 (loadw symbol bsp-tn
(- binding-symbol-slot binding-size
))
196 (loadw value bsp-tn
(- binding-value-slot binding-size
))
197 (storew value symbol symbol-value-slot other-pointer-lowtag
)
198 (storew zero-tn bsp-tn
(- binding-symbol-slot binding-size
))
199 (storew zero-tn bsp-tn
(- binding-value-slot binding-size
))
200 (inst addu bsp-tn bsp-tn
(* -
2 n-word-bytes
))))
203 (define-vop (unbind-to-here)
204 (:args
(arg :scs
(descriptor-reg any-reg
) :target where
))
205 (:temporary
(:scs
(any-reg) :from
(:argument
0)) where
)
206 (:temporary
(:scs
(descriptor-reg)) symbol value
)
208 (let ((loop (gen-label))
212 (inst beq where bsp-tn done
)
216 (loadw symbol bsp-tn
(- binding-symbol-slot binding-size
))
217 (inst beq symbol skip
)
218 (loadw value bsp-tn
(- binding-value-slot binding-size
))
219 (storew value symbol symbol-value-slot other-pointer-lowtag
)
220 (storew zero-tn bsp-tn
(- binding-symbol-slot binding-size
))
223 (storew zero-tn bsp-tn
(- binding-value-slot binding-size
))
224 (inst addu bsp-tn bsp-tn
(* -
2 n-word-bytes
))
225 (inst bne where bsp-tn loop
)
232 ;;;; Closure indexing.
234 (define-full-reffer closure-index-ref
*
235 closure-info-offset fun-pointer-lowtag
236 (descriptor-reg any-reg
) * %closure-index-ref
)
238 (define-full-setter set-funcallable-instance-info
*
239 funcallable-instance-info-offset fun-pointer-lowtag
240 (descriptor-reg any-reg null zero
) * %set-funcallable-instance-info
)
242 (define-full-reffer funcallable-instance-info
*
243 funcallable-instance-info-offset fun-pointer-lowtag
244 (descriptor-reg any-reg
) * %funcallable-instance-info
)
246 (define-vop (closure-ref slot-ref
)
247 (:variant closure-info-offset fun-pointer-lowtag
))
249 (define-vop (closure-init slot-set
)
250 (:variant closure-info-offset fun-pointer-lowtag
))
252 (define-vop (closure-init-from-fp)
253 (:args
(object :scs
(descriptor-reg)))
256 (storew cfp-tn object
(+ closure-info-offset offset
) fun-pointer-lowtag
)))
258 ;;;; Value Cell hackery.
260 (define-vop (value-cell-ref cell-ref
)
261 (:variant value-cell-value-slot other-pointer-lowtag
))
263 (define-vop (value-cell-set cell-set
)
264 (:variant value-cell-value-slot other-pointer-lowtag
))
268 ;;;; Instance hackery:
270 (define-vop (instance-length)
272 (:translate %instance-length
)
273 (:args
(struct :scs
(descriptor-reg)))
274 (:temporary
(:scs
(non-descriptor-reg)) temp
)
275 (:results
(res :scs
(unsigned-reg)))
276 (:result-types positive-fixnum
)
278 (loadw temp struct
0 instance-pointer-lowtag
)
279 (inst srl res temp n-widetag-bits
)))
281 (define-full-reffer instance-index-ref
* instance-slots-offset
282 instance-pointer-lowtag
(descriptor-reg any-reg
) * %instance-ref
)
284 (define-full-setter instance-index-set
* instance-slots-offset
285 instance-pointer-lowtag
(descriptor-reg any-reg null zero
) * %instance-set
)
289 ;;;; Code object frobbing.
291 (define-full-reffer code-header-ref
* 0 other-pointer-lowtag
292 (descriptor-reg any-reg
) * code-header-ref
)
294 (define-full-setter code-header-set
* 0 other-pointer-lowtag
295 (descriptor-reg any-reg null zero
) * code-header-set
)
299 ;;;; raw instance slot accessors
301 (define-vop (raw-instance-ref/word
)
302 (:translate %raw-instance-ref
/word
)
304 (:args
(object :scs
(descriptor-reg))
305 (index :scs
(any-reg)))
306 (:arg-types
* positive-fixnum
)
307 (:results
(value :scs
(unsigned-reg)))
308 (:temporary
(:scs
(interior-reg)) lip
)
309 (:result-types unsigned-num
)
311 (inst addu lip object index
)
312 (loadw value lip instance-slots-offset instance-pointer-lowtag
)))
314 (define-vop (raw-instance-set/word
)
315 (:translate %raw-instance-set
/word
)
317 (:args
(object :scs
(descriptor-reg))
318 (index :scs
(any-reg))
319 (value :scs
(unsigned-reg) :target result
))
320 (:arg-types
* positive-fixnum unsigned-num
)
321 (:results
(result :scs
(unsigned-reg)))
322 (:temporary
(:scs
(interior-reg)) lip
)
323 (:result-types unsigned-num
)
325 (inst addu lip object index
)
326 (storew value lip instance-slots-offset instance-pointer-lowtag
)
327 (move result value
)))
329 (define-vop (raw-instance-ref/single
)
330 (:translate %raw-instance-ref
/single
)
332 (:args
(object :scs
(descriptor-reg))
333 (index :scs
(any-reg)))
334 (:arg-types
* positive-fixnum
)
335 (:results
(value :scs
(single-reg)))
336 (:temporary
(:scs
(interior-reg)) lip
)
337 (:result-types single-float
)
339 (inst addu lip object index
)
340 (inst lwc1 value lip
(- (* instance-slots-offset n-word-bytes
)
341 instance-pointer-lowtag
))))
343 (define-vop (raw-instance-set/single
)
344 (:translate %raw-instance-set
/single
)
346 (:args
(object :scs
(descriptor-reg))
347 (index :scs
(any-reg))
348 (value :scs
(single-reg) :target result
))
349 (:arg-types
* positive-fixnum single-float
)
350 (:results
(result :scs
(single-reg)))
351 (:temporary
(:scs
(interior-reg)) lip
)
352 (:result-types single-float
)
354 (inst addu lip object index
)
355 (inst swc1 value lip
(- (* instance-slots-offset n-word-bytes
)
356 instance-pointer-lowtag
))
357 (unless (location= result value
)
358 (inst fmove
:single result value
))))
360 (define-vop (raw-instance-ref/double
)
361 (:translate %raw-instance-ref
/double
)
363 (:args
(object :scs
(descriptor-reg))
364 (index :scs
(any-reg)))
365 (:arg-types
* positive-fixnum
)
366 (:results
(value :scs
(double-reg)))
367 (:temporary
(:scs
(interior-reg)) lip
)
368 (:result-types double-float
)
370 (inst addu lip object index
)
371 (let ((immediate-offset (- (* instance-slots-offset n-word-bytes
)
372 instance-pointer-lowtag
)))
373 (ecase *backend-byte-order
*
374 (:big-endian
(inst lwc1-odd value lip immediate-offset
))
375 (:little-endian
(inst lwc1 value lip immediate-offset
))))
376 (let ((immediate-offset (- (* (1+ instance-slots-offset
) n-word-bytes
)
377 instance-pointer-lowtag
)))
378 (ecase *backend-byte-order
*
379 (:big-endian
(inst lwc1 value lip immediate-offset
))
380 (:little-endian
(inst lwc1-odd value lip immediate-offset
))))))
382 (define-vop (raw-instance-set/double
)
383 (:translate %raw-instance-set
/double
)
385 (:args
(object :scs
(descriptor-reg))
386 (index :scs
(any-reg))
387 (value :scs
(double-reg) :target result
))
388 (:arg-types
* positive-fixnum double-float
)
389 (:results
(result :scs
(double-reg)))
390 (:temporary
(:scs
(interior-reg)) lip
)
391 (:result-types double-float
)
393 (inst addu lip object index
)
394 (let ((immediate-offset (- (* instance-slots-offset n-word-bytes
)
395 instance-pointer-lowtag
)))
396 (ecase *backend-byte-order
*
397 (:big-endian
(inst swc1-odd value lip immediate-offset
))
398 (:little-endian
(inst swc1 value lip immediate-offset
))))
399 (let ((immediate-offset (- (* (1+ instance-slots-offset
) n-word-bytes
)
400 instance-pointer-lowtag
)))
401 (ecase *backend-byte-order
*
402 (:big-endian
(inst swc1 value lip immediate-offset
))
403 (:little-endian
(inst swc1-odd value lip immediate-offset
))))
404 (unless (location= result value
)
405 (inst fmove
:double result value
))))
407 (define-vop (raw-instance-ref/complex-single
)
408 (:translate %raw-instance-ref
/complex-single
)
410 (:args
(object :scs
(descriptor-reg))
411 (index :scs
(any-reg)))
412 (:arg-types
* positive-fixnum
)
413 (:results
(value :scs
(complex-single-reg)))
414 (:temporary
(:scs
(interior-reg)) lip
)
415 (:result-types complex-single-float
)
417 (inst addu lip object index
)
419 (complex-single-reg-real-tn value
)
421 (- (* instance-slots-offset n-word-bytes
)
422 instance-pointer-lowtag
))
424 (complex-single-reg-imag-tn value
)
426 (- (* (1+ instance-slots-offset
) n-word-bytes
)
427 instance-pointer-lowtag
))))
429 (define-vop (raw-instance-set/complex-single
)
430 (:translate %raw-instance-set
/complex-single
)
432 (:args
(object :scs
(descriptor-reg))
433 (index :scs
(any-reg))
434 (value :scs
(complex-single-reg) :target result
))
435 (:arg-types
* positive-fixnum complex-single-float
)
436 (:results
(result :scs
(complex-single-reg)))
437 (:temporary
(:scs
(interior-reg)) lip
)
438 (:result-types complex-single-float
)
440 (inst addu lip object index
)
441 (let ((value-real (complex-single-reg-real-tn value
))
442 (result-real (complex-single-reg-real-tn result
)))
446 (- (* instance-slots-offset n-word-bytes
)
447 instance-pointer-lowtag
))
448 (unless (location= result-real value-real
)
449 (inst fmove
:single result-real value-real
)))
450 (let ((value-imag (complex-single-reg-imag-tn value
))
451 (result-imag (complex-single-reg-imag-tn result
)))
455 (- (* (1+ instance-slots-offset
) n-word-bytes
)
456 instance-pointer-lowtag
))
457 (unless (location= result-imag value-imag
)
458 (inst fmove
:single result-imag value-imag
)))))
460 (define-vop (raw-instance-ref/complex-double
)
461 (:translate %raw-instance-ref
/complex-double
)
463 (:args
(object :scs
(descriptor-reg))
464 (index :scs
(any-reg)))
465 (:arg-types
* positive-fixnum
)
466 (:results
(value :scs
(complex-double-reg)))
467 (:temporary
(:scs
(interior-reg)) lip
)
468 (:result-types complex-double-float
)
470 (inst addu lip object index
)
471 (let ((immediate-offset (- (* instance-slots-offset n-word-bytes
)
472 instance-pointer-lowtag
)))
473 (ecase *backend-byte-order
*
474 (:big-endian
(inst lwc1-odd
475 (complex-double-reg-real-tn value
)
478 (:little-endian
(inst lwc1
479 (complex-double-reg-real-tn value
)
482 (let ((immediate-offset (- (* (1+ instance-slots-offset
) n-word-bytes
)
483 instance-pointer-lowtag
)))
484 (ecase *backend-byte-order
*
485 (:big-endian
(inst lwc1
486 (complex-double-reg-real-tn value
)
489 (:little-endian
(inst lwc1-odd
490 (complex-double-reg-real-tn value
)
493 (let ((immediate-offset (- (* (+ instance-slots-offset
2) n-word-bytes
)
494 instance-pointer-lowtag
)))
495 (ecase *backend-byte-order
*
496 (:big-endian
(inst lwc1-odd
497 (complex-double-reg-imag-tn value
)
500 (:little-endian
(inst lwc1
501 (complex-double-reg-imag-tn value
)
504 (let ((immediate-offset (- (* (+ instance-slots-offset
3) n-word-bytes
)
505 instance-pointer-lowtag
)))
506 (ecase *backend-byte-order
*
507 (:big-endian
(inst lwc1
508 (complex-double-reg-imag-tn value
)
511 (:little-endian
(inst lwc1-odd
512 (complex-double-reg-imag-tn value
)
514 immediate-offset
))))))
516 (define-vop (raw-instance-set/complex-double
)
517 (:translate %raw-instance-set
/complex-double
)
519 (:args
(object :scs
(descriptor-reg))
520 (index :scs
(any-reg))
521 (value :scs
(complex-double-reg) :target result
))
522 (:arg-types
* positive-fixnum complex-double-float
)
523 (:results
(result :scs
(complex-double-reg)))
524 (:temporary
(:scs
(interior-reg)) lip
)
525 (:result-types complex-double-float
)
527 (inst addu lip object index
)
528 (let ((value-real (complex-double-reg-real-tn value
))
529 (result-real (complex-double-reg-real-tn result
)))
530 (let ((immediate-offset (- (* instance-slots-offset n-word-bytes
)
531 instance-pointer-lowtag
)))
532 (ecase *backend-byte-order
*
533 (:big-endian
(inst swc1-odd
537 (:little-endian
(inst swc1
541 (let ((immediate-offset (- (* (1+ instance-slots-offset
) n-word-bytes
)
542 instance-pointer-lowtag
)))
543 (ecase *backend-byte-order
*
544 (:big-endian
(inst swc1
548 (:little-endian
(inst swc1-odd
552 (unless (location= result-real value-real
)
553 (inst fmove
:double result-real value-real
)))
554 (let ((value-imag (complex-double-reg-imag-tn value
))
555 (result-imag (complex-double-reg-imag-tn result
)))
556 (let ((immediate-offset (- (* (+ instance-slots-offset
2) n-word-bytes
)
557 instance-pointer-lowtag
)))
558 (ecase *backend-byte-order
*
559 (:big-endian
(inst swc1-odd
563 (:little-endian
(inst swc1
567 (let ((immediate-offset (- (* (+ instance-slots-offset
3) n-word-bytes
)
568 instance-pointer-lowtag
)))
569 (ecase *backend-byte-order
*
570 (:big-endian
(inst swc1
574 (:little-endian
(inst swc1-odd
578 (unless (location= result-imag value-imag
)
579 (inst fmove
:double result-imag value-imag
)))))