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 ;;;; Fdefinition (fdefn) objects.
98 (define-vop (fdefn-fun cell-ref)
99 (:variant fdefn-fun-slot other-pointer-lowtag))
101 (define-vop (safe-fdefn-fun)
102 (:args (object :scs (descriptor-reg) :target obj-temp))
103 (:results (value :scs (descriptor-reg any-reg)))
105 (:save-p :compute-only)
106 (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
108 (move obj-temp object)
109 (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag)
110 (inst cmpw value null-tn)
111 (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp)))
112 (inst beq err-lab))))
114 (define-vop (set-fdefn-fun)
116 (:translate (setf fdefn-fun))
117 (:args (function :scs (descriptor-reg) :target result)
118 (fdefn :scs (descriptor-reg)))
119 (:temporary (:scs (interior-reg)) lip)
120 (:temporary (:scs (non-descriptor-reg)) type)
121 (:results (result :scs (descriptor-reg)))
123 (let ((normal-fn (gen-label)))
124 (load-type type function (- fun-pointer-lowtag))
125 (inst cmpwi type simple-fun-header-widetag)
126 ;;(inst mr lip function)
127 (inst addi lip function
128 (- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag))
130 (inst lr lip (make-fixup "closure_tramp" :foreign))
131 (emit-label normal-fn)
132 (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
133 (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
134 (move result function))))
136 (define-vop (fdefn-makunbound)
138 (:translate fdefn-makunbound)
139 (:args (fdefn :scs (descriptor-reg) :target result))
140 (:temporary (:scs (non-descriptor-reg)) temp)
141 (:results (result :scs (descriptor-reg)))
143 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag)
144 (inst lr temp (make-fixup "undefined_tramp" :foreign))
145 (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
146 (move result fdefn)))
150 ;;;; Binding and Unbinding.
152 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
153 ;;; the symbol on the binding stack and stuff the new value into the
157 (:args (val :scs (any-reg descriptor-reg))
158 (symbol :scs (descriptor-reg)))
159 (:temporary (:scs (descriptor-reg)) temp)
161 (loadw temp symbol symbol-value-slot other-pointer-lowtag)
162 (inst addi bsp-tn bsp-tn (* 2 n-word-bytes))
163 (storew temp bsp-tn (- binding-value-slot binding-size))
164 (storew symbol bsp-tn (- binding-symbol-slot binding-size))
165 (storew val symbol symbol-value-slot other-pointer-lowtag)))
169 (:temporary (:scs (descriptor-reg)) symbol value)
171 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
172 (loadw value bsp-tn (- binding-value-slot binding-size))
173 (storew value symbol symbol-value-slot other-pointer-lowtag)
174 (storew zero-tn bsp-tn (- binding-value-slot binding-size))
175 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
176 (inst subi bsp-tn bsp-tn (* 2 n-word-bytes))))
179 (define-vop (unbind-to-here)
180 (:args (arg :scs (descriptor-reg any-reg) :target where))
181 (:temporary (:scs (any-reg) :from (:argument 0)) where)
182 (:temporary (:scs (descriptor-reg)) symbol value)
184 (let ((loop (gen-label))
188 (inst cmpw where bsp-tn)
192 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
193 (inst cmpwi symbol 0)
195 (loadw value bsp-tn (- binding-value-slot binding-size))
196 (storew value symbol symbol-value-slot other-pointer-lowtag)
197 (storew zero-tn bsp-tn (- binding-value-slot binding-size))
198 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
201 (inst subi bsp-tn bsp-tn (* 2 n-word-bytes))
202 (inst cmpw where bsp-tn)
209 ;;;; Closure indexing.
211 (define-vop (closure-index-ref word-index-ref)
212 (:variant closure-info-offset fun-pointer-lowtag)
213 (:translate %closure-index-ref))
215 (define-vop (funcallable-instance-info word-index-ref)
216 (:variant funcallable-instance-info-offset fun-pointer-lowtag)
217 (:translate %funcallable-instance-info))
219 (define-vop (set-funcallable-instance-info word-index-set)
220 (:variant funcallable-instance-info-offset fun-pointer-lowtag)
221 (:translate %set-funcallable-instance-info))
223 (define-vop (funcallable-instance-lexenv cell-ref)
224 (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
227 (define-vop (closure-ref slot-ref)
228 (:variant closure-info-offset fun-pointer-lowtag))
230 (define-vop (closure-init slot-set)
231 (:variant closure-info-offset fun-pointer-lowtag))
234 ;;;; Value Cell hackery.
236 (define-vop (value-cell-ref cell-ref)
237 (:variant value-cell-value-slot other-pointer-lowtag))
239 (define-vop (value-cell-set cell-set)
240 (:variant value-cell-value-slot other-pointer-lowtag))
244 ;;;; Instance hackery:
246 (define-vop (instance-length)
248 (:translate %instance-length)
249 (:args (struct :scs (descriptor-reg)))
250 (:temporary (:scs (non-descriptor-reg)) temp)
251 (:results (res :scs (unsigned-reg)))
252 (:result-types positive-fixnum)
254 (loadw temp struct 0 instance-pointer-lowtag)
255 (inst srwi res temp n-widetag-bits)))
257 (define-vop (instance-index-ref word-index-ref)
259 (:translate %instance-ref)
260 (:variant instance-slots-offset instance-pointer-lowtag)
261 (:arg-types instance positive-fixnum))
263 (define-vop (instance-index-set word-index-set)
265 (:translate %instance-set)
266 (:variant instance-slots-offset instance-pointer-lowtag)
267 (:arg-types instance positive-fixnum *))
272 ;;;; Code object frobbing.
274 (define-vop (code-header-ref word-index-ref)
275 (:translate code-header-ref)
277 (:variant 0 other-pointer-lowtag))
279 (define-vop (code-header-set word-index-set)
280 (:translate code-header-set)
282 (:variant 0 other-pointer-lowtag))
286 ;;;; raw instance slot accessors
288 (define-vop (raw-instance-ref/word)
289 (:translate %raw-instance-ref/word)
291 (:args (object :scs (descriptor-reg))
292 (index :scs (any-reg)))
293 (:arg-types * positive-fixnum)
294 (:results (value :scs (unsigned-reg)))
295 (:temporary (:scs (non-descriptor-reg)) offset)
296 (:result-types unsigned-num)
298 (loadw offset object 0 instance-pointer-lowtag)
299 ;; offset = (offset >> n-widetag-bits) << 2
300 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
301 (inst subf offset index offset)
305 (- (* (1- instance-slots-offset) n-word-bytes)
306 instance-pointer-lowtag))
307 (inst lwzx value object offset)))
309 (define-vop (raw-instance-set/word)
310 (:translate %raw-instance-set/word)
312 (:args (object :scs (descriptor-reg))
313 (index :scs (any-reg))
314 (value :scs (unsigned-reg)))
315 (:arg-types * positive-fixnum unsigned-num)
316 (:results (result :scs (unsigned-reg)))
317 (:temporary (:scs (non-descriptor-reg)) offset)
318 (:result-types unsigned-num)
320 (loadw offset object 0 instance-pointer-lowtag)
321 ;; offset = (offset >> n-widetag-bits) << 2
322 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
323 (inst subf offset index offset)
327 (- (* (1- instance-slots-offset) n-word-bytes)
328 instance-pointer-lowtag))
329 (inst stwx value object offset)
330 (move result value)))
332 (define-vop (raw-instance-ref/single)
333 (:translate %raw-instance-ref/single)
335 (:args (object :scs (descriptor-reg))
336 (index :scs (any-reg)))
337 (:arg-types * positive-fixnum)
338 (:results (value :scs (single-reg)))
339 (:temporary (:scs (non-descriptor-reg)) offset)
340 (:result-types single-float)
342 (loadw offset object 0 instance-pointer-lowtag)
343 ;; offset = (offset >> n-widetag-bits) << 2
344 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
345 (inst subf offset index offset)
349 (- (* (1- instance-slots-offset) n-word-bytes)
350 instance-pointer-lowtag))
351 (inst lfsx value object offset)))
353 (define-vop (raw-instance-set/single)
354 (:translate %raw-instance-set/single)
356 (:args (object :scs (descriptor-reg))
357 (index :scs (any-reg))
358 (value :scs (single-reg) :target result))
359 (:arg-types * positive-fixnum single-float)
360 (:results (result :scs (single-reg)))
361 (:result-types single-float)
362 (:temporary (:scs (non-descriptor-reg)) offset)
364 (loadw offset object 0 instance-pointer-lowtag)
365 ;; offset = (offset >> n-widetag-bits) << 2
366 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
367 (inst subf offset index offset)
371 (- (* (1- instance-slots-offset) n-word-bytes)
372 instance-pointer-lowtag))
373 (inst stfsx value object offset)
374 (unless (location= result value)
375 (inst frsp result value))))
377 (define-vop (raw-instance-ref/double)
378 (:translate %raw-instance-ref/double)
380 (:args (object :scs (descriptor-reg))
381 (index :scs (any-reg)))
382 (:arg-types * positive-fixnum)
383 (:results (value :scs (double-reg)))
384 (:temporary (:scs (non-descriptor-reg)) offset)
385 (:result-types double-float)
387 (loadw offset object 0 instance-pointer-lowtag)
388 ;; offset = (offset >> n-widetag-bits) << 2
389 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
390 (inst subf offset index offset)
394 (- (* (- instance-slots-offset 2) n-word-bytes)
395 instance-pointer-lowtag))
396 (inst lfdx value object offset)))
398 (define-vop (raw-instance-set/double)
399 (:translate %raw-instance-set/double)
401 (:args (object :scs (descriptor-reg))
402 (index :scs (any-reg))
403 (value :scs (double-reg) :target result))
404 (:arg-types * positive-fixnum double-float)
405 (:results (result :scs (double-reg)))
406 (:result-types double-float)
407 (:temporary (:scs (non-descriptor-reg)) offset)
409 (loadw offset object 0 instance-pointer-lowtag)
410 ;; offset = (offset >> n-widetag-bits) << 2
411 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
412 (inst subf offset index offset)
416 (- (* (- instance-slots-offset 2) n-word-bytes)
417 instance-pointer-lowtag))
418 (inst stfdx value object offset)
419 (unless (location= result value)
420 (inst fmr result value))))
422 (define-vop (raw-instance-ref/complex-single)
423 (:translate %raw-instance-ref/complex-single)
425 (:args (object :scs (descriptor-reg))
426 (index :scs (any-reg)))
427 (:arg-types * positive-fixnum)
428 (:results (value :scs (complex-single-reg)))
429 (:temporary (:scs (non-descriptor-reg)) offset)
430 (:result-types complex-single-float)
432 (loadw offset object 0 instance-pointer-lowtag)
433 ;; offset = (offset >> n-widetag-bits) << 2
434 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
435 (inst subf offset index offset)
439 (- (* (- instance-slots-offset 2) n-word-bytes)
440 instance-pointer-lowtag))
441 (inst lfsx (complex-single-reg-real-tn value) object offset)
442 (inst addi offset offset n-word-bytes)
443 (inst lfsx (complex-single-reg-imag-tn value) object offset)))
445 (define-vop (raw-instance-set/complex-single)
446 (:translate %raw-instance-set/complex-single)
448 (:args (object :scs (descriptor-reg))
449 (index :scs (any-reg))
450 (value :scs (complex-single-reg) :target result))
451 (:arg-types * positive-fixnum complex-single-float)
452 (:results (result :scs (complex-single-reg)))
453 (:result-types complex-single-float)
454 (:temporary (:scs (non-descriptor-reg)) offset)
456 (loadw offset object 0 instance-pointer-lowtag)
457 ;; offset = (offset >> n-widetag-bits) << 2
458 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
459 (inst subf offset index offset)
463 (- (* (- instance-slots-offset 2) n-word-bytes)
464 instance-pointer-lowtag))
465 (let ((value-real (complex-single-reg-real-tn value))
466 (result-real (complex-single-reg-real-tn result)))
467 (inst stfsx value-real object offset)
468 (unless (location= result-real value-real)
469 (inst frsp result-real value-real)))
470 (inst addi offset offset n-word-bytes)
471 (let ((value-imag (complex-single-reg-imag-tn value))
472 (result-imag (complex-single-reg-imag-tn result)))
473 (inst stfsx value-imag object offset)
474 (unless (location= result-imag value-imag)
475 (inst frsp result-imag value-imag)))))
477 (define-vop (raw-instance-ref/complex-double)
478 (:translate %raw-instance-ref/complex-double)
480 (:args (object :scs (descriptor-reg))
481 (index :scs (any-reg)))
482 (:arg-types * positive-fixnum)
483 (:results (value :scs (complex-double-reg)))
484 (:temporary (:scs (non-descriptor-reg)) offset)
485 (:result-types complex-double-float)
487 (loadw offset object 0 instance-pointer-lowtag)
488 ;; offset = (offset >> n-widetag-bits) << 2
489 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
490 (inst subf offset index offset)
494 (- (* (- instance-slots-offset 4) n-word-bytes)
495 instance-pointer-lowtag))
496 (inst lfdx (complex-double-reg-real-tn value) object offset)
497 (inst addi offset offset (* 2 n-word-bytes))
498 (inst lfdx (complex-double-reg-imag-tn value) object offset)))
500 (define-vop (raw-instance-set/complex-double)
501 (:translate %raw-instance-set/complex-double)
503 (:args (object :scs (descriptor-reg))
504 (index :scs (any-reg))
505 (value :scs (complex-double-reg) :target result))
506 (:arg-types * positive-fixnum complex-double-float)
507 (:results (result :scs (complex-double-reg)))
508 (:result-types complex-double-float)
509 (:temporary (:scs (non-descriptor-reg)) offset)
511 (loadw offset object 0 instance-pointer-lowtag)
512 ;; offset = (offset >> n-widetag-bits) << 2
513 (inst rlwinm offset offset (- 32 (- n-widetag-bits 2)) (- n-widetag-bits 2) 29)
514 (inst subf offset index offset)
518 (- (* (- instance-slots-offset 4) n-word-bytes)
519 instance-pointer-lowtag))
520 (let ((value-real (complex-double-reg-real-tn value))
521 (result-real (complex-double-reg-real-tn result)))
522 (inst stfdx value-real object offset)
523 (unless (location= result-real value-real)
524 (inst fmr result-real value-real)))
525 (inst addi offset offset (* 2 n-word-bytes))
526 (let ((value-imag (complex-double-reg-imag-tn value))
527 (result-imag (complex-double-reg-imag-tn result)))
528 (inst stfdx value-imag object offset)
529 (unless (location= result-imag value-imag)
530 (inst fmr result-imag value-imag)))))