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)))
28 (:info name offset lowtag)
32 (storew value object offset lowtag)))
35 ;;;; Symbol hacking VOPs:
37 ;;; The compiler likes to be able to directly SET symbols.
38 (define-vop (set cell-set)
39 (:variant symbol-value-slot other-pointer-lowtag))
41 ;;; Do a cell ref with an error check for being unbound.
42 (define-vop (checked-cell-ref)
43 (:args (object :scs (descriptor-reg) :target obj-temp))
44 (:results (value :scs (descriptor-reg any-reg)))
47 (:save-p :compute-only)
48 (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
50 ;;; With SYMBOL-VALUE, we check that the value isn't the trap object.
51 ;;; So SYMBOL-VALUE of NIL is NIL.
52 (define-vop (symbol-value checked-cell-ref)
53 (:translate symbol-value)
55 (move obj-temp object)
56 (loadw value obj-temp symbol-value-slot other-pointer-lowtag)
57 (let ((err-lab (generate-error-code vop 'unbound-symbol-error obj-temp)))
58 (inst cmpwi value unbound-marker-widetag)
61 ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell
63 (define-vop (boundp-frob)
64 (:args (object :scs (descriptor-reg)))
68 (:temporary (:scs (descriptor-reg)) value))
70 (define-vop (boundp boundp-frob)
73 (loadw value object symbol-value-slot other-pointer-lowtag)
74 (inst cmpwi value unbound-marker-widetag)
75 (inst b? (if not-p :eq :ne) target)))
77 (define-vop (fast-symbol-value cell-ref)
78 (:variant symbol-value-slot other-pointer-lowtag)
80 (:translate symbol-value))
82 (define-vop (symbol-hash)
84 (:translate symbol-hash)
85 (:args (symbol :scs (descriptor-reg)))
86 (:results (res :scs (any-reg)))
87 (:result-types positive-fixnum)
89 ;; The symbol-hash slot of NIL holds NIL because it is also the
90 ;; cdr slot, so we have to strip off the two low bits to make sure
91 ;; it is a fixnum. The lowtag selection magic that is required to
92 ;; ensure this is explained in the comment in objdef.lisp
93 (loadw res symbol symbol-hash-slot other-pointer-lowtag)
94 (inst clrrwi res res n-fixnum-tag-bits)))
96 ;;; On unithreaded builds these are just copies of the non-global versions.
97 (define-vop (%set-symbol-global-value set))
98 (define-vop (symbol-global-value symbol-value)
99 (:translate symbol-global-value))
100 (define-vop (fast-symbol-global-value fast-symbol-value)
101 (:translate symbol-global-value))
103 ;;;; Fdefinition (fdefn) objects.
105 (define-vop (fdefn-fun cell-ref)
106 (:variant fdefn-fun-slot other-pointer-lowtag))
108 (define-vop (safe-fdefn-fun)
109 (:args (object :scs (descriptor-reg) :target obj-temp))
110 (:results (value :scs (descriptor-reg any-reg)))
112 (:save-p :compute-only)
113 (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
115 (move obj-temp object)
116 (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag)
117 (inst cmpw value null-tn)
118 (let ((err-lab (generate-error-code vop 'undefined-fun-error obj-temp)))
119 (inst beq err-lab))))
121 (define-vop (set-fdefn-fun)
123 (:translate (setf fdefn-fun))
124 (:args (function :scs (descriptor-reg) :target result)
125 (fdefn :scs (descriptor-reg)))
126 (:temporary (:scs (interior-reg)) lip)
127 (:temporary (:scs (non-descriptor-reg)) type)
128 (:results (result :scs (descriptor-reg)))
130 (let ((normal-fn (gen-label)))
131 (load-type type function (- fun-pointer-lowtag))
132 (inst cmpwi type simple-fun-header-widetag)
133 ;;(inst mr lip function)
134 (inst addi lip function
135 (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag))
137 (inst lr lip (make-fixup "closure_tramp" :foreign))
138 (emit-label normal-fn)
139 (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
140 (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
141 (move result function))))
143 (define-vop (fdefn-makunbound)
145 (:translate fdefn-makunbound)
146 (:args (fdefn :scs (descriptor-reg) :target result))
147 (:temporary (:scs (non-descriptor-reg)) temp)
148 (:results (result :scs (descriptor-reg)))
150 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag)
151 (inst lr temp (make-fixup "undefined_tramp" :foreign))
152 (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
153 (move result fdefn)))
157 ;;;; Binding and Unbinding.
159 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
160 ;;; the symbol on the binding stack and stuff the new value into the
164 (:args (val :scs (any-reg descriptor-reg))
165 (symbol :scs (descriptor-reg)))
166 (:temporary (:scs (descriptor-reg)) temp)
168 (loadw temp symbol symbol-value-slot other-pointer-lowtag)
169 (inst addi bsp-tn bsp-tn (* 2 n-word-bytes))
170 (storew temp bsp-tn (- binding-value-slot binding-size))
171 (storew symbol bsp-tn (- binding-symbol-slot binding-size))
172 (storew val symbol symbol-value-slot other-pointer-lowtag)))
176 (:temporary (:scs (descriptor-reg)) symbol value)
178 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
179 (loadw value bsp-tn (- binding-value-slot binding-size))
180 (storew value symbol symbol-value-slot other-pointer-lowtag)
181 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
182 (storew zero-tn bsp-tn (- binding-value-slot binding-size))
183 (inst subi bsp-tn bsp-tn (* 2 n-word-bytes))))
186 (define-vop (unbind-to-here)
187 (:args (arg :scs (descriptor-reg any-reg) :target where))
188 (:temporary (:scs (any-reg) :from (:argument 0)) where)
189 (:temporary (:scs (descriptor-reg)) symbol value)
191 (let ((loop (gen-label))
195 (inst cmpw where bsp-tn)
199 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
200 (inst cmpwi symbol 0)
202 (loadw value bsp-tn (- binding-value-slot binding-size))
203 (storew value symbol symbol-value-slot other-pointer-lowtag)
204 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
207 (storew zero-tn bsp-tn (- binding-value-slot binding-size))
208 (inst subi bsp-tn bsp-tn (* 2 n-word-bytes))
209 (inst cmpw where bsp-tn)
216 ;;;; Closure indexing.
218 (define-vop (closure-index-ref word-index-ref)
219 (:variant closure-info-offset fun-pointer-lowtag)
220 (:translate %closure-index-ref))
222 (define-vop (funcallable-instance-info word-index-ref)
223 (:variant funcallable-instance-info-offset fun-pointer-lowtag)
224 (:translate %funcallable-instance-info))
226 (define-vop (set-funcallable-instance-info word-index-set)
227 (:variant funcallable-instance-info-offset fun-pointer-lowtag)
228 (:translate %set-funcallable-instance-info))
230 (define-vop (closure-ref slot-ref)
231 (:variant closure-info-offset fun-pointer-lowtag))
233 (define-vop (closure-init slot-set)
234 (:variant closure-info-offset fun-pointer-lowtag))
237 ;;;; Value Cell hackery.
239 (define-vop (value-cell-ref cell-ref)
240 (:variant value-cell-value-slot other-pointer-lowtag))
242 (define-vop (value-cell-set cell-set)
243 (:variant value-cell-value-slot other-pointer-lowtag))
247 ;;;; Instance hackery:
249 (define-vop (instance-length)
251 (:translate %instance-length)
252 (:args (struct :scs (descriptor-reg)))
253 (:temporary (:scs (non-descriptor-reg)) temp)
254 (:results (res :scs (unsigned-reg)))
255 (:result-types positive-fixnum)
257 (loadw temp struct 0 instance-pointer-lowtag)
258 (inst srwi res temp n-widetag-bits)))
260 (define-vop (instance-index-ref word-index-ref)
262 (:translate %instance-ref)
263 (:variant instance-slots-offset instance-pointer-lowtag)
264 (:arg-types instance positive-fixnum))
266 (define-vop (instance-index-set word-index-set)
268 (:translate %instance-set)
269 (:variant instance-slots-offset instance-pointer-lowtag)
270 (:arg-types instance positive-fixnum *))
275 ;;;; Code object frobbing.
277 (define-vop (code-header-ref word-index-ref)
278 (:translate code-header-ref)
280 (:variant 0 other-pointer-lowtag))
282 (define-vop (code-header-set word-index-set)
283 (:translate code-header-set)
285 (:variant 0 other-pointer-lowtag))
289 ;;;; raw instance slot accessors
291 (defun offset-for-raw-slot (instance-length index n-words)
292 (+ (* (- instance-length instance-slots-offset index (1- n-words))
294 (- instance-pointer-lowtag)))
296 (define-vop (raw-instance-init/word)
297 (:args (object :scs (descriptor-reg))
298 (value :scs (unsigned-reg)))
299 (:arg-types * unsigned-num)
300 (:info instance-length index)
302 (inst stw value object (offset-for-raw-slot instance-length index 1))))
304 (define-vop (raw-instance-ref/word)
305 (:translate %raw-instance-ref/word)
307 (:args (object :scs (descriptor-reg))
308 (index :scs (any-reg)))
309 (:arg-types * positive-fixnum)
310 (:results (value :scs (unsigned-reg)))
311 (:temporary (:scs (non-descriptor-reg)) offset)
312 (:result-types unsigned-num)
314 (loadw offset object 0 instance-pointer-lowtag)
315 ;; offset = (offset >> n-widetag-bits) << 2
316 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
317 (inst subf offset index offset)
321 (- (* (1- instance-slots-offset) n-word-bytes)
322 instance-pointer-lowtag))
323 (inst lwzx value object offset)))
325 (define-vop (raw-instance-set/word)
326 (:translate %raw-instance-set/word)
328 (:args (object :scs (descriptor-reg))
329 (index :scs (any-reg))
330 (value :scs (unsigned-reg)))
331 (:arg-types * positive-fixnum unsigned-num)
332 (:results (result :scs (unsigned-reg)))
333 (:temporary (:scs (non-descriptor-reg)) offset)
334 (:result-types unsigned-num)
336 (loadw offset object 0 instance-pointer-lowtag)
337 ;; offset = (offset >> n-widetag-bits) << 2
338 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
339 (inst subf offset index offset)
343 (- (* (1- instance-slots-offset) n-word-bytes)
344 instance-pointer-lowtag))
345 (inst stwx value object offset)
346 (move result value)))
348 (define-vop (raw-instance-init/single)
349 (:args (object :scs (descriptor-reg))
350 (value :scs (single-reg)))
351 (:arg-types * single-float)
352 (:info instance-length index)
354 (inst stfs value object (offset-for-raw-slot instance-length index 1))))
356 (define-vop (raw-instance-ref/single)
357 (:translate %raw-instance-ref/single)
359 (:args (object :scs (descriptor-reg))
360 (index :scs (any-reg)))
361 (:arg-types * positive-fixnum)
362 (:results (value :scs (single-reg)))
363 (:temporary (:scs (non-descriptor-reg)) offset)
364 (:result-types single-float)
366 (loadw offset object 0 instance-pointer-lowtag)
367 ;; offset = (offset >> n-widetag-bits) << 2
368 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
369 (inst subf offset index offset)
373 (- (* (1- instance-slots-offset) n-word-bytes)
374 instance-pointer-lowtag))
375 (inst lfsx value object offset)))
377 (define-vop (raw-instance-set/single)
378 (:translate %raw-instance-set/single)
380 (:args (object :scs (descriptor-reg))
381 (index :scs (any-reg))
382 (value :scs (single-reg) :target result))
383 (:arg-types * positive-fixnum single-float)
384 (:results (result :scs (single-reg)))
385 (:result-types single-float)
386 (:temporary (:scs (non-descriptor-reg)) offset)
388 (loadw offset object 0 instance-pointer-lowtag)
389 ;; offset = (offset >> n-widetag-bits) << 2
390 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
391 (inst subf offset index offset)
395 (- (* (1- instance-slots-offset) n-word-bytes)
396 instance-pointer-lowtag))
397 (inst stfsx value object offset)
398 (unless (location= result value)
399 (inst frsp result value))))
401 (define-vop (raw-instance-init/double)
402 (:args (object :scs (descriptor-reg))
403 (value :scs (double-reg)))
404 (:arg-types * double-float)
405 (:info instance-length index)
407 (inst stfd value object (offset-for-raw-slot instance-length index 2))))
409 (define-vop (raw-instance-ref/double)
410 (:translate %raw-instance-ref/double)
412 (:args (object :scs (descriptor-reg))
413 (index :scs (any-reg)))
414 (:arg-types * positive-fixnum)
415 (:results (value :scs (double-reg)))
416 (:temporary (:scs (non-descriptor-reg)) offset)
417 (:result-types double-float)
419 (loadw offset object 0 instance-pointer-lowtag)
420 ;; offset = (offset >> n-widetag-bits) << 2
421 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
422 (inst subf offset index offset)
426 (- (* (- instance-slots-offset 2) n-word-bytes)
427 instance-pointer-lowtag))
428 (inst lfdx value object offset)))
430 (define-vop (raw-instance-set/double)
431 (:translate %raw-instance-set/double)
433 (:args (object :scs (descriptor-reg))
434 (index :scs (any-reg))
435 (value :scs (double-reg) :target result))
436 (:arg-types * positive-fixnum double-float)
437 (:results (result :scs (double-reg)))
438 (:result-types double-float)
439 (:temporary (:scs (non-descriptor-reg)) offset)
441 (loadw offset object 0 instance-pointer-lowtag)
442 ;; offset = (offset >> n-widetag-bits) << 2
443 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
444 (inst subf offset index offset)
448 (- (* (- instance-slots-offset 2) n-word-bytes)
449 instance-pointer-lowtag))
450 (inst stfdx value object offset)
451 (unless (location= result value)
452 (inst fmr result value))))
454 (define-vop (raw-instance-init/complex-single)
455 (:args (object :scs (descriptor-reg))
456 (value :scs (complex-single-reg)))
457 (:arg-types * complex-single-float)
458 (:info instance-length index)
460 (inst stfs (complex-single-reg-real-tn value)
461 object (offset-for-raw-slot instance-length index 2))
462 (inst stfs (complex-single-reg-imag-tn value)
463 object (offset-for-raw-slot instance-length index 1))))
465 (define-vop (raw-instance-ref/complex-single)
466 (:translate %raw-instance-ref/complex-single)
468 (:args (object :scs (descriptor-reg))
469 (index :scs (any-reg)))
470 (:arg-types * positive-fixnum)
471 (:results (value :scs (complex-single-reg)))
472 (:temporary (:scs (non-descriptor-reg)) offset)
473 (:result-types complex-single-float)
475 (loadw offset object 0 instance-pointer-lowtag)
476 ;; offset = (offset >> n-widetag-bits) << 2
477 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
478 (inst subf offset index offset)
482 (- (* (- instance-slots-offset 2) n-word-bytes)
483 instance-pointer-lowtag))
484 (inst lfsx (complex-single-reg-real-tn value) object offset)
485 (inst addi offset offset n-word-bytes)
486 (inst lfsx (complex-single-reg-imag-tn value) object offset)))
488 (define-vop (raw-instance-set/complex-single)
489 (:translate %raw-instance-set/complex-single)
491 (:args (object :scs (descriptor-reg))
492 (index :scs (any-reg))
493 (value :scs (complex-single-reg) :target result))
494 (:arg-types * positive-fixnum complex-single-float)
495 (:results (result :scs (complex-single-reg)))
496 (:result-types complex-single-float)
497 (:temporary (:scs (non-descriptor-reg)) offset)
499 (loadw offset object 0 instance-pointer-lowtag)
500 ;; offset = (offset >> n-widetag-bits) << 2
501 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
502 (inst subf offset index offset)
506 (- (* (- instance-slots-offset 2) n-word-bytes)
507 instance-pointer-lowtag))
508 (let ((value-real (complex-single-reg-real-tn value))
509 (result-real (complex-single-reg-real-tn result)))
510 (inst stfsx value-real object offset)
511 (unless (location= result-real value-real)
512 (inst frsp result-real value-real)))
513 (inst addi offset offset n-word-bytes)
514 (let ((value-imag (complex-single-reg-imag-tn value))
515 (result-imag (complex-single-reg-imag-tn result)))
516 (inst stfsx value-imag object offset)
517 (unless (location= result-imag value-imag)
518 (inst frsp result-imag value-imag)))))
520 (define-vop (raw-instance-init/complex-double)
521 (:args (object :scs (descriptor-reg))
522 (value :scs (complex-double-reg)))
523 (:arg-types * complex-double-float)
524 (:info instance-length index)
526 (inst stfd (complex-single-reg-real-tn value)
527 object (offset-for-raw-slot instance-length index 4))
528 (inst stfd (complex-double-reg-imag-tn value)
529 object (offset-for-raw-slot instance-length index 2))))
531 (define-vop (raw-instance-ref/complex-double)
532 (:translate %raw-instance-ref/complex-double)
534 (:args (object :scs (descriptor-reg))
535 (index :scs (any-reg)))
536 (:arg-types * positive-fixnum)
537 (:results (value :scs (complex-double-reg)))
538 (:temporary (:scs (non-descriptor-reg)) offset)
539 (:result-types complex-double-float)
541 (loadw offset object 0 instance-pointer-lowtag)
542 ;; offset = (offset >> n-widetag-bits) << 2
543 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
544 (inst subf offset index offset)
548 (- (* (- instance-slots-offset 4) n-word-bytes)
549 instance-pointer-lowtag))
550 (inst lfdx (complex-double-reg-real-tn value) object offset)
551 (inst addi offset offset (* 2 n-word-bytes))
552 (inst lfdx (complex-double-reg-imag-tn value) object offset)))
554 (define-vop (raw-instance-set/complex-double)
555 (:translate %raw-instance-set/complex-double)
557 (:args (object :scs (descriptor-reg))
558 (index :scs (any-reg))
559 (value :scs (complex-double-reg) :target result))
560 (:arg-types * positive-fixnum complex-double-float)
561 (:results (result :scs (complex-double-reg)))
562 (:result-types complex-double-float)
563 (:temporary (:scs (non-descriptor-reg)) offset)
565 (loadw offset object 0 instance-pointer-lowtag)
566 ;; offset = (offset >> n-widetag-bits) << 2
567 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
568 (inst subf offset index offset)
572 (- (* (- instance-slots-offset 4) n-word-bytes)
573 instance-pointer-lowtag))
574 (let ((value-real (complex-double-reg-real-tn value))
575 (result-real (complex-double-reg-real-tn result)))
576 (inst stfdx value-real object offset)
577 (unless (location= result-real value-real)
578 (inst fmr result-real value-real)))
579 (inst addi offset offset (* 2 n-word-bytes))
580 (let ((value-imag (complex-double-reg-imag-tn value))
581 (result-imag (complex-double-reg-imag-tn result)))
582 (inst stfdx value-imag object offset)
583 (unless (location= result-imag value-imag)
584 (inst fmr result-imag value-imag)))))