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 ;;; 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.
104 (define-vop (fdefn-fun cell-ref)
105 (:variant fdefn-fun-slot other-pointer-lowtag))
107 (define-vop (safe-fdefn-fun)
108 (:args (object :scs (descriptor-reg) :target obj-temp))
109 (:results (value :scs (descriptor-reg any-reg)))
111 (:save-p :compute-only)
112 (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
114 (move obj-temp object)
115 (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag)
116 (inst cmp value null-tn)
117 (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp)))
118 (inst b :eq 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 cmp type simple-fun-header-widetag)
133 (inst b :eq normal-fn)
134 (inst move lip function)
135 (inst li lip (make-fixup "closure_tramp" :foreign))
136 (emit-label normal-fn)
137 (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
138 (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
139 (move result function))))
141 (define-vop (fdefn-makunbound)
143 (:translate fdefn-makunbound)
144 (:args (fdefn :scs (descriptor-reg) :target result))
145 (:temporary (:scs (non-descriptor-reg)) temp)
146 (:results (result :scs (descriptor-reg)))
148 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag)
149 (inst li temp (make-fixup "undefined_tramp" :foreign))
150 (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
151 (move result fdefn)))
155 ;;;; Binding and Unbinding.
157 ;;; Establish VAL as a binding for SYMBOL. Save the old value and the
158 ;;; symbol on the binding stack and stuff the new value into the
161 (:args (val :scs (any-reg descriptor-reg))
162 (symbol :scs (descriptor-reg)))
163 (:temporary (:scs (descriptor-reg)) temp)
165 (loadw temp symbol symbol-value-slot other-pointer-lowtag)
166 (inst add bsp-tn bsp-tn (* 2 n-word-bytes))
167 (storew temp bsp-tn (- binding-value-slot binding-size))
168 (storew symbol bsp-tn (- binding-symbol-slot binding-size))
169 (storew val symbol symbol-value-slot other-pointer-lowtag)))
172 (:temporary (:scs (descriptor-reg)) symbol value)
174 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
175 (loadw value bsp-tn (- binding-value-slot binding-size))
176 (storew value symbol symbol-value-slot other-pointer-lowtag)
177 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
178 (storew zero-tn bsp-tn (- binding-value-slot binding-size))
179 (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))))
181 (define-vop (unbind-to-here)
182 (:args (arg :scs (descriptor-reg any-reg) :target where))
183 (:temporary (:scs (any-reg) :from (:argument 0)) where)
184 (:temporary (:scs (descriptor-reg)) symbol value)
186 (let ((loop (gen-label))
190 (inst cmp where bsp-tn)
195 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
198 (loadw value bsp-tn (- binding-value-slot binding-size))
199 (storew value symbol symbol-value-slot other-pointer-lowtag)
200 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
203 (storew zero-tn bsp-tn (- binding-value-slot binding-size))
204 (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))
205 (inst cmp where bsp-tn)
211 ;;;; closure indexing.
213 (define-vop (closure-index-ref word-index-ref)
214 (:variant closure-info-offset fun-pointer-lowtag)
215 (:translate %closure-index-ref))
217 (define-vop (funcallable-instance-info word-index-ref)
218 (:variant funcallable-instance-info-offset fun-pointer-lowtag)
219 (:translate %funcallable-instance-info))
221 (define-vop (set-funcallable-instance-info word-index-set)
222 (:variant funcallable-instance-info-offset fun-pointer-lowtag)
223 (:translate %set-funcallable-instance-info))
225 (define-vop (closure-ref slot-ref)
226 (:variant closure-info-offset fun-pointer-lowtag))
228 (define-vop (closure-init slot-set)
229 (:variant closure-info-offset fun-pointer-lowtag))
231 (define-vop (closure-init-from-fp)
232 (:args (object :scs (descriptor-reg)))
235 (storew cfp-tn object (+ closure-info-offset 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))
245 ;;;; instance hackery:
247 (define-vop (instance-length)
249 (:translate %instance-length)
250 (:args (struct :scs (descriptor-reg)))
251 (:temporary (:scs (non-descriptor-reg)) temp)
252 (:results (res :scs (unsigned-reg)))
253 (:result-types positive-fixnum)
255 (loadw temp struct 0 instance-pointer-lowtag)
256 (inst srl res temp n-widetag-bits)))
258 (define-vop (instance-index-ref word-index-ref)
260 (:translate %instance-ref)
261 (:variant instance-slots-offset instance-pointer-lowtag)
262 (:arg-types * positive-fixnum))
264 (define-vop (instance-index-set word-index-set)
266 (:translate %instance-set)
267 (:variant instance-slots-offset instance-pointer-lowtag)
268 (:arg-types * positive-fixnum *))
270 ;;;; Code object frobbing.
272 (define-vop (code-header-ref word-index-ref)
273 (:translate code-header-ref)
275 (:variant 0 other-pointer-lowtag))
277 (define-vop (code-header-set word-index-set)
278 (:translate code-header-set)
280 (:variant 0 other-pointer-lowtag))
284 ;;;; raw instance slot accessors
286 (define-vop (raw-instance-ref/word)
287 (:translate %raw-instance-ref/word)
289 (:args (object :scs (descriptor-reg))
290 (index :scs (any-reg)))
291 (:arg-types * positive-fixnum)
292 (:results (value :scs (unsigned-reg)))
293 (:temporary (:scs (non-descriptor-reg)) offset)
294 (:result-types unsigned-num)
296 (loadw offset object 0 instance-pointer-lowtag)
297 (inst srl offset offset n-widetag-bits)
298 (inst sll offset offset n-fixnum-tag-bits)
299 (inst sub offset offset index)
303 (- (* (1- instance-slots-offset) n-word-bytes)
304 instance-pointer-lowtag))
305 (inst ld value object offset)))
307 (define-vop (raw-instance-set/word)
308 (:translate %raw-instance-set/word)
310 (:args (object :scs (descriptor-reg))
311 (index :scs (any-reg))
312 (value :scs (unsigned-reg)))
313 (:arg-types * positive-fixnum unsigned-num)
314 (:results (result :scs (unsigned-reg)))
315 (:temporary (:scs (non-descriptor-reg)) offset)
316 (:result-types unsigned-num)
318 (loadw offset object 0 instance-pointer-lowtag)
319 (inst srl offset offset n-widetag-bits)
320 (inst sll offset offset n-fixnum-tag-bits)
321 (inst sub offset offset index)
325 (- (* (1- instance-slots-offset) n-word-bytes)
326 instance-pointer-lowtag))
327 (inst st value object offset)
328 (move result value)))
330 (define-vop (raw-instance-ref/single)
331 (:translate %raw-instance-ref/single)
333 (:args (object :scs (descriptor-reg))
334 (index :scs (any-reg)))
335 (:arg-types * positive-fixnum)
336 (:results (value :scs (single-reg)))
337 (:temporary (:scs (non-descriptor-reg)) offset)
338 (:result-types single-float)
340 (loadw offset object 0 instance-pointer-lowtag)
341 (inst srl offset offset n-widetag-bits)
342 (inst sll offset offset n-fixnum-tag-bits)
343 (inst sub offset offset index)
347 (- (* (1- instance-slots-offset) n-word-bytes)
348 instance-pointer-lowtag))
349 (inst ldf value object offset)))
351 (define-vop (raw-instance-set/single)
352 (:translate %raw-instance-set/single)
354 (:args (object :scs (descriptor-reg))
355 (index :scs (any-reg))
356 (value :scs (single-reg) :target result))
357 (:arg-types * positive-fixnum single-float)
358 (:results (result :scs (single-reg)))
359 (:result-types single-float)
360 (:temporary (:scs (non-descriptor-reg)) offset)
362 (loadw offset object 0 instance-pointer-lowtag)
363 (inst srl offset offset n-widetag-bits)
364 (inst sll offset offset n-fixnum-tag-bits)
365 (inst sub offset offset index)
369 (- (* (1- instance-slots-offset) n-word-bytes)
370 instance-pointer-lowtag))
371 (inst stf value object offset)
372 (unless (location= result value)
373 (inst fmovs result value))))
375 (define-vop (raw-instance-ref/double)
376 (:translate %raw-instance-ref/double)
378 (:args (object :scs (descriptor-reg))
379 (index :scs (any-reg)))
380 (:arg-types * positive-fixnum)
381 (:results (value :scs (double-reg)))
382 (:temporary (:scs (non-descriptor-reg)) offset)
383 (:result-types double-float)
385 (loadw offset object 0 instance-pointer-lowtag)
386 (inst srl offset offset n-widetag-bits)
387 (inst sll offset offset n-fixnum-tag-bits)
388 (inst sub offset offset index)
392 (- (* (- instance-slots-offset 2) n-word-bytes)
393 instance-pointer-lowtag))
394 (inst lddf value object offset)))
396 (define-vop (raw-instance-set/double)
397 (:translate %raw-instance-set/double)
399 (:args (object :scs (descriptor-reg))
400 (index :scs (any-reg))
401 (value :scs (double-reg) :target result))
402 (:arg-types * positive-fixnum double-float)
403 (:results (result :scs (double-reg)))
404 (:result-types double-float)
405 (:temporary (:scs (non-descriptor-reg)) offset)
407 (loadw offset object 0 instance-pointer-lowtag)
408 (inst srl offset offset n-widetag-bits)
409 (inst sll offset offset n-fixnum-tag-bits)
410 (inst sub offset offset index)
414 (- (* (- instance-slots-offset 2) n-word-bytes)
415 instance-pointer-lowtag))
416 (inst stdf value object offset)
417 (unless (location= result value)
418 (move-double-reg result value))))
420 (define-vop (raw-instance-ref/complex-single)
421 (:translate %raw-instance-ref/complex-single)
423 (:args (object :scs (descriptor-reg))
424 (index :scs (any-reg)))
425 (:arg-types * positive-fixnum)
426 (:results (value :scs (complex-single-reg)))
427 (:temporary (:scs (non-descriptor-reg)) offset)
428 (:result-types complex-single-float)
430 (loadw offset object 0 instance-pointer-lowtag)
431 (inst srl offset offset n-widetag-bits)
432 (inst sll offset offset n-fixnum-tag-bits)
433 (inst sub offset offset index)
437 (- (* (- instance-slots-offset 2) n-word-bytes)
438 instance-pointer-lowtag))
439 (inst ldf (complex-single-reg-real-tn value) object offset)
440 (inst add offset offset n-word-bytes)
441 (inst ldf (complex-single-reg-imag-tn value) object offset)))
443 (define-vop (raw-instance-set/complex-single)
444 (:translate %raw-instance-set/complex-single)
446 (:args (object :scs (descriptor-reg))
447 (index :scs (any-reg))
448 (value :scs (complex-single-reg) :target result))
449 (:arg-types * positive-fixnum complex-single-float)
450 (:results (result :scs (complex-single-reg)))
451 (:result-types complex-single-float)
452 (:temporary (:scs (non-descriptor-reg)) offset)
454 (loadw offset object 0 instance-pointer-lowtag)
455 (inst srl offset offset n-widetag-bits)
456 (inst sll offset offset n-fixnum-tag-bits)
457 (inst sub offset offset index)
461 (- (* (- instance-slots-offset 2) n-word-bytes)
462 instance-pointer-lowtag))
463 (let ((value-real (complex-single-reg-real-tn value))
464 (result-real (complex-single-reg-real-tn result)))
465 (inst stf value-real object offset)
466 (unless (location= result-real value-real)
467 (inst fmovs result-real value-real)))
468 (inst add offset offset n-word-bytes)
469 (let ((value-imag (complex-single-reg-imag-tn value))
470 (result-imag (complex-single-reg-imag-tn result)))
471 (inst stf value-imag object offset)
472 (unless (location= result-imag value-imag)
473 (inst fmovs result-imag value-imag)))))
475 (define-vop (raw-instance-ref/complex-double)
476 (:translate %raw-instance-ref/complex-double)
478 (:args (object :scs (descriptor-reg))
479 (index :scs (any-reg)))
480 (:arg-types * positive-fixnum)
481 (:results (value :scs (complex-double-reg)))
482 (:temporary (:scs (non-descriptor-reg)) offset)
483 (:result-types complex-double-float)
485 (loadw offset object 0 instance-pointer-lowtag)
486 (inst srl offset offset n-widetag-bits)
487 (inst sll offset offset n-fixnum-tag-bits)
488 (inst sub offset offset index)
492 (- (* (- instance-slots-offset 4) n-word-bytes)
493 instance-pointer-lowtag))
494 (inst lddf (complex-double-reg-real-tn value) object offset)
495 (inst add offset offset (* 2 n-word-bytes))
496 (inst lddf (complex-double-reg-imag-tn value) object offset)))
498 (define-vop (raw-instance-set/complex-double)
499 (:translate %raw-instance-set/complex-double)
501 (:args (object :scs (descriptor-reg))
502 (index :scs (any-reg))
503 (value :scs (complex-double-reg) :target result))
504 (:arg-types * positive-fixnum complex-double-float)
505 (:results (result :scs (complex-double-reg)))
506 (:result-types complex-double-float)
507 (:temporary (:scs (non-descriptor-reg)) offset)
509 (loadw offset object 0 instance-pointer-lowtag)
510 (inst srl offset offset n-widetag-bits)
511 (inst sll offset offset n-fixnum-tag-bits)
512 (inst sub offset offset index)
516 (- (* (- instance-slots-offset 4) n-word-bytes)
517 instance-pointer-lowtag))
518 (let ((value-real (complex-double-reg-real-tn value))
519 (result-real (complex-double-reg-real-tn result)))
520 (inst stdf value-real object offset)
521 (unless (location= result-real value-real)
522 (move-double-reg result-real value-real)))
523 (inst add offset offset (* 2 n-word-bytes))
524 (let ((value-imag (complex-double-reg-imag-tn value))
525 (result-imag (complex-double-reg-imag-tn result)))
526 (inst stdf value-imag object offset)
527 (unless (location= result-imag value-imag)
528 (move-double-reg result-imag value-imag)))))