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.
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)))
27 (:info name offset lowtag)
31 (storew value object offset lowtag)))
33 ;;;; Symbol hacking VOPs:
35 ;;; The compiler likes to be able to directly SET symbols.
36 (define-vop (set cell-set)
37 (:variant symbol-value-slot other-pointer-lowtag))
39 ;;; Do a cell ref with an error check for being unbound.
40 (define-vop (checked-cell-ref)
41 (:args (object :scs (descriptor-reg) :target obj-temp))
42 (:results (value :scs (descriptor-reg any-reg)))
45 (:save-p :compute-only)
46 (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
48 ;;; With Symbol-Value, we check that the value isn't the trap object.
49 ;;; So Symbol-Value of NIL is NIL.
50 (define-vop (symbol-value checked-cell-ref)
51 (:translate symbol-value)
53 (move obj-temp object)
54 (loadw value obj-temp symbol-value-slot other-pointer-lowtag)
55 (let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
56 (inst cmp value unbound-marker-widetag)
60 ;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell
62 (define-vop (boundp-frob)
63 (:args (object :scs (descriptor-reg)))
67 (:temporary (:scs (descriptor-reg)) value))
69 (define-vop (boundp boundp-frob)
72 (loadw value object symbol-value-slot other-pointer-lowtag)
73 (inst cmp value unbound-marker-widetag)
74 (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 andn res res fixnum-tag-mask)))
96 ;;;; FDEFINITION (fdefn) objects.
97 (define-vop (fdefn-fun cell-ref)
98 (:variant fdefn-fun-slot other-pointer-lowtag))
100 (define-vop (safe-fdefn-fun)
101 (:args (object :scs (descriptor-reg) :target obj-temp))
102 (:results (value :scs (descriptor-reg any-reg)))
104 (:save-p :compute-only)
105 (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
107 (move obj-temp object)
108 (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag)
109 (inst cmp value null-tn)
110 (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp)))
111 (inst b :eq 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 cmp type simple-fun-header-widetag)
126 (inst b :eq normal-fn)
127 (inst move lip function)
128 (inst li lip (make-fixup "closure_tramp" :foreign))
129 (emit-label normal-fn)
130 (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
131 (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
132 (move result function))))
134 (define-vop (fdefn-makunbound)
136 (:translate fdefn-makunbound)
137 (:args (fdefn :scs (descriptor-reg) :target result))
138 (:temporary (:scs (non-descriptor-reg)) temp)
139 (:results (result :scs (descriptor-reg)))
141 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag)
142 (inst li temp (make-fixup "undefined_tramp" :foreign))
143 (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
144 (move result fdefn)))
148 ;;;; Binding and Unbinding.
150 ;;; Establish VAL as a binding for SYMBOL. Save the old value and the
151 ;;; symbol on the binding stack and stuff the new value into the
154 (:args (val :scs (any-reg descriptor-reg))
155 (symbol :scs (descriptor-reg)))
156 (:temporary (:scs (descriptor-reg)) temp)
158 (loadw temp symbol symbol-value-slot other-pointer-lowtag)
159 (inst add bsp-tn bsp-tn (* 2 n-word-bytes))
160 (storew temp bsp-tn (- binding-value-slot binding-size))
161 (storew symbol bsp-tn (- binding-symbol-slot binding-size))
162 (storew val symbol symbol-value-slot other-pointer-lowtag)))
165 (:temporary (:scs (descriptor-reg)) symbol value)
167 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
168 (loadw value bsp-tn (- binding-value-slot binding-size))
169 (storew value symbol symbol-value-slot other-pointer-lowtag)
170 (storew zero-tn bsp-tn (- binding-value-slot binding-size))
171 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
172 (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))))
174 (define-vop (unbind-to-here)
175 (:args (arg :scs (descriptor-reg any-reg) :target where))
176 (:temporary (:scs (any-reg) :from (:argument 0)) where)
177 (:temporary (:scs (descriptor-reg)) symbol value)
179 (let ((loop (gen-label))
183 (inst cmp where bsp-tn)
188 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
191 (loadw value bsp-tn (- binding-value-slot binding-size))
192 (storew value symbol symbol-value-slot other-pointer-lowtag)
193 (storew zero-tn bsp-tn (- binding-value-slot binding-size))
194 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
197 (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))
198 (inst cmp where bsp-tn)
204 ;;;; closure indexing.
206 (define-vop (closure-index-ref word-index-ref)
207 (:variant closure-info-offset fun-pointer-lowtag)
208 (:translate %closure-index-ref))
210 (define-vop (funcallable-instance-info word-index-ref)
211 (:variant funcallable-instance-info-offset fun-pointer-lowtag)
212 (:translate %funcallable-instance-info))
214 (define-vop (set-funcallable-instance-info word-index-set)
215 (:variant funcallable-instance-info-offset fun-pointer-lowtag)
216 (:translate %set-funcallable-instance-info))
218 (define-vop (funcallable-instance-lexenv cell-ref)
219 (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
222 (define-vop (closure-ref slot-ref)
223 (:variant closure-info-offset fun-pointer-lowtag))
225 (define-vop (closure-init slot-set)
226 (:variant closure-info-offset fun-pointer-lowtag))
228 ;;;; value cell hackery.
230 (define-vop (value-cell-ref cell-ref)
231 (:variant value-cell-value-slot other-pointer-lowtag))
233 (define-vop (value-cell-set cell-set)
234 (:variant value-cell-value-slot other-pointer-lowtag))
236 ;;;; instance hackery:
238 (define-vop (instance-length)
240 (:translate %instance-length)
241 (:args (struct :scs (descriptor-reg)))
242 (:temporary (:scs (non-descriptor-reg)) temp)
243 (:results (res :scs (unsigned-reg)))
244 (:result-types positive-fixnum)
246 (loadw temp struct 0 instance-pointer-lowtag)
247 (inst srl res temp n-widetag-bits)))
249 (define-vop (instance-index-ref word-index-ref)
251 (:translate %instance-ref)
252 (:variant instance-slots-offset instance-pointer-lowtag)
253 (:arg-types * positive-fixnum))
255 (define-vop (instance-index-set word-index-set)
257 (:translate %instance-set)
258 (:variant instance-slots-offset instance-pointer-lowtag)
259 (:arg-types * positive-fixnum *))
261 ;;;; Code object frobbing.
263 (define-vop (code-header-ref word-index-ref)
264 (:translate code-header-ref)
266 (:variant 0 other-pointer-lowtag))
268 (define-vop (code-header-set word-index-set)
269 (:translate code-header-set)
271 (:variant 0 other-pointer-lowtag))
275 ;;;; raw instance slot accessors
277 (define-vop (raw-instance-ref/word)
278 (:translate %raw-instance-ref/word)
280 (:args (object :scs (descriptor-reg))
281 (index :scs (any-reg)))
282 (:arg-types * positive-fixnum)
283 (:results (value :scs (unsigned-reg)))
284 (:temporary (:scs (non-descriptor-reg)) offset)
285 (:result-types unsigned-num)
287 (loadw offset object 0 instance-pointer-lowtag)
288 (inst srl offset offset n-widetag-bits)
289 (inst sll offset offset 2)
290 (inst sub offset offset index)
294 (- (* (1- instance-slots-offset) n-word-bytes)
295 instance-pointer-lowtag))
296 (inst ld value object offset)))
298 (define-vop (raw-instance-set/word)
299 (:translate %raw-instance-set/word)
301 (:args (object :scs (descriptor-reg))
302 (index :scs (any-reg))
303 (value :scs (unsigned-reg)))
304 (:arg-types * positive-fixnum unsigned-num)
305 (:results (result :scs (unsigned-reg)))
306 (:temporary (:scs (non-descriptor-reg)) offset)
307 (:result-types unsigned-num)
309 (loadw offset object 0 instance-pointer-lowtag)
310 (inst srl offset offset n-widetag-bits)
311 (inst sll offset offset 2)
312 (inst sub offset offset index)
316 (- (* (1- instance-slots-offset) n-word-bytes)
317 instance-pointer-lowtag))
318 (inst st value object offset)
319 (move result value)))
321 (define-vop (raw-instance-ref/single)
322 (:translate %raw-instance-ref/single)
324 (:args (object :scs (descriptor-reg))
325 (index :scs (any-reg)))
326 (:arg-types * positive-fixnum)
327 (:results (value :scs (single-reg)))
328 (:temporary (:scs (non-descriptor-reg)) offset)
329 (:result-types single-float)
331 (loadw offset object 0 instance-pointer-lowtag)
332 (inst srl offset offset n-widetag-bits)
333 (inst sll offset offset 2)
334 (inst sub offset offset index)
338 (- (* (1- instance-slots-offset) n-word-bytes)
339 instance-pointer-lowtag))
340 (inst ldf value object offset)))
342 (define-vop (raw-instance-set/single)
343 (:translate %raw-instance-set/single)
345 (:args (object :scs (descriptor-reg))
346 (index :scs (any-reg))
347 (value :scs (single-reg) :target result))
348 (:arg-types * positive-fixnum single-float)
349 (:results (result :scs (single-reg)))
350 (:result-types single-float)
351 (:temporary (:scs (non-descriptor-reg)) offset)
353 (loadw offset object 0 instance-pointer-lowtag)
354 (inst srl offset offset n-widetag-bits)
355 (inst sll offset offset 2)
356 (inst sub offset offset index)
360 (- (* (1- instance-slots-offset) n-word-bytes)
361 instance-pointer-lowtag))
362 (inst stf value object offset)
363 (unless (location= result value)
364 (inst fmovs result value))))
366 (define-vop (raw-instance-ref/double)
367 (:translate %raw-instance-ref/double)
369 (:args (object :scs (descriptor-reg))
370 (index :scs (any-reg)))
371 (:arg-types * positive-fixnum)
372 (:results (value :scs (double-reg)))
373 (:temporary (:scs (non-descriptor-reg)) offset)
374 (:result-types double-float)
376 (loadw offset object 0 instance-pointer-lowtag)
377 (inst srl offset offset n-widetag-bits)
378 (inst sll offset offset 2)
379 (inst sub offset offset index)
383 (- (* (- instance-slots-offset 2) n-word-bytes)
384 instance-pointer-lowtag))
385 (inst lddf value object offset)))
387 (define-vop (raw-instance-set/double)
388 (:translate %raw-instance-set/double)
390 (:args (object :scs (descriptor-reg))
391 (index :scs (any-reg))
392 (value :scs (double-reg) :target result))
393 (:arg-types * positive-fixnum double-float)
394 (:results (result :scs (double-reg)))
395 (:result-types double-float)
396 (:temporary (:scs (non-descriptor-reg)) offset)
398 (loadw offset object 0 instance-pointer-lowtag)
399 (inst srl offset offset n-widetag-bits)
400 (inst sll offset offset 2)
401 (inst sub offset offset index)
405 (- (* (- instance-slots-offset 2) n-word-bytes)
406 instance-pointer-lowtag))
407 (inst stdf value object offset)
408 (unless (location= result value)
409 (move-double-reg result value))))
411 (define-vop (raw-instance-ref/complex-single)
412 (:translate %raw-instance-ref/complex-single)
414 (:args (object :scs (descriptor-reg))
415 (index :scs (any-reg)))
416 (:arg-types * positive-fixnum)
417 (:results (value :scs (complex-single-reg)))
418 (:temporary (:scs (non-descriptor-reg)) offset)
419 (:result-types complex-single-float)
421 (loadw offset object 0 instance-pointer-lowtag)
422 (inst srl offset offset n-widetag-bits)
423 (inst sll offset offset 2)
424 (inst sub offset offset index)
428 (- (* (- instance-slots-offset 2) n-word-bytes)
429 instance-pointer-lowtag))
430 (inst ldf (complex-single-reg-real-tn value) object offset)
431 (inst add offset offset n-word-bytes)
432 (inst ldf (complex-single-reg-imag-tn value) object offset)))
434 (define-vop (raw-instance-set/complex-single)
435 (:translate %raw-instance-set/complex-single)
437 (:args (object :scs (descriptor-reg))
438 (index :scs (any-reg))
439 (value :scs (complex-single-reg) :target result))
440 (:arg-types * positive-fixnum complex-single-float)
441 (:results (result :scs (complex-single-reg)))
442 (:result-types complex-single-float)
443 (:temporary (:scs (non-descriptor-reg)) offset)
445 (loadw offset object 0 instance-pointer-lowtag)
446 (inst srl offset offset n-widetag-bits)
447 (inst sll offset offset 2)
448 (inst sub offset offset index)
452 (- (* (- instance-slots-offset 2) n-word-bytes)
453 instance-pointer-lowtag))
454 (let ((value-real (complex-single-reg-real-tn value))
455 (result-real (complex-single-reg-real-tn result)))
456 (inst stf value-real object offset)
457 (unless (location= result-real value-real)
458 (inst fmovs result-real value-real)))
459 (inst add offset offset n-word-bytes)
460 (let ((value-imag (complex-single-reg-imag-tn value))
461 (result-imag (complex-single-reg-imag-tn result)))
462 (inst stf value-imag object offset)
463 (unless (location= result-imag value-imag)
464 (inst fmovs result-imag value-imag)))))
466 (define-vop (raw-instance-ref/complex-double)
467 (:translate %raw-instance-ref/complex-double)
469 (:args (object :scs (descriptor-reg))
470 (index :scs (any-reg)))
471 (:arg-types * positive-fixnum)
472 (:results (value :scs (complex-double-reg)))
473 (:temporary (:scs (non-descriptor-reg)) offset)
474 (:result-types complex-double-float)
476 (loadw offset object 0 instance-pointer-lowtag)
477 (inst srl offset offset n-widetag-bits)
478 (inst sll offset offset 2)
479 (inst sub offset offset index)
483 (- (* (- instance-slots-offset 4) n-word-bytes)
484 instance-pointer-lowtag))
485 (inst lddf (complex-double-reg-real-tn value) object offset)
486 (inst add offset offset (* 2 n-word-bytes))
487 (inst lddf (complex-double-reg-imag-tn value) object offset)))
489 (define-vop (raw-instance-set/complex-double)
490 (:translate %raw-instance-set/complex-double)
492 (:args (object :scs (descriptor-reg))
493 (index :scs (any-reg))
494 (value :scs (complex-double-reg) :target result))
495 (:arg-types * positive-fixnum complex-double-float)
496 (:results (result :scs (complex-double-reg)))
497 (:result-types complex-double-float)
498 (:temporary (:scs (non-descriptor-reg)) offset)
500 (loadw offset object 0 instance-pointer-lowtag)
501 (inst srl offset offset n-widetag-bits)
502 (inst sll offset offset 2)
503 (inst sub offset offset index)
507 (- (* (- instance-slots-offset 4) n-word-bytes)
508 instance-pointer-lowtag))
509 (let ((value-real (complex-double-reg-real-tn value))
510 (result-real (complex-double-reg-real-tn result)))
511 (inst stdf value-real object offset)
512 (unless (location= result-real value-real)
513 (move-double-reg result-real value-real)))
514 (inst add offset offset (* 2 n-word-bytes))
515 (let ((value-imag (complex-double-reg-imag-tn value))
516 (result-imag (complex-double-reg-imag-tn result)))
517 (inst stdf value-imag object offset)
518 (unless (location= result-imag value-imag)
519 (move-double-reg result-imag value-imag)))))