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))
83 ;;;; FDEFINITION (fdefn) objects.
84 (define-vop (fdefn-fun cell-ref)
85 (:variant fdefn-fun-slot other-pointer-lowtag))
87 (define-vop (safe-fdefn-fun)
88 (:args (object :scs (descriptor-reg) :target obj-temp))
89 (:results (value :scs (descriptor-reg any-reg)))
91 (:save-p :compute-only)
92 (:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
94 (move obj-temp object)
95 (loadw value obj-temp fdefn-fun-slot other-pointer-lowtag)
96 (inst cmp value null-tn)
97 (let ((err-lab (generate-error-code vop undefined-fun-error obj-temp)))
101 (define-vop (set-fdefn-fun)
103 (:translate (setf fdefn-fun))
104 (:args (function :scs (descriptor-reg) :target result)
105 (fdefn :scs (descriptor-reg)))
106 (:temporary (:scs (interior-reg)) lip)
107 (:temporary (:scs (non-descriptor-reg)) type)
108 (:results (result :scs (descriptor-reg)))
110 (let ((normal-fn (gen-label)))
111 (load-type type function (- fun-pointer-lowtag))
112 (inst cmp type simple-fun-header-widetag)
113 (inst b :eq normal-fn)
114 (inst move lip function)
115 (inst li lip (make-fixup (extern-alien-name "closure_tramp") :foreign))
116 (emit-label normal-fn)
117 (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
118 (storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
119 (move result function))))
121 (define-vop (fdefn-makunbound)
123 (:translate fdefn-makunbound)
124 (:args (fdefn :scs (descriptor-reg) :target result))
125 (:temporary (:scs (non-descriptor-reg)) temp)
126 (:results (result :scs (descriptor-reg)))
128 (storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag)
129 (inst li temp (make-fixup (extern-alien-name "undefined_tramp") :foreign))
130 (storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
131 (move result fdefn)))
135 ;;;; Binding and Unbinding.
137 ;;; Establish VAL as a binding for SYMBOL. Save the old value and the
138 ;;; symbol on the binding stack and stuff the new value into the
141 (:args (val :scs (any-reg descriptor-reg))
142 (symbol :scs (descriptor-reg)))
143 (:temporary (:scs (descriptor-reg)) temp)
145 (loadw temp symbol symbol-value-slot other-pointer-lowtag)
146 (inst add bsp-tn bsp-tn (* 2 n-word-bytes))
147 (storew temp bsp-tn (- binding-value-slot binding-size))
148 (storew symbol bsp-tn (- binding-symbol-slot binding-size))
149 (storew val symbol symbol-value-slot other-pointer-lowtag)))
152 (:temporary (:scs (descriptor-reg)) symbol value)
154 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
155 (loadw value bsp-tn (- binding-value-slot binding-size))
156 (storew value symbol symbol-value-slot other-pointer-lowtag)
157 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
158 (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))))
160 (define-vop (unbind-to-here)
161 (:args (arg :scs (descriptor-reg any-reg) :target where))
162 (:temporary (:scs (any-reg) :from (:argument 0)) where)
163 (:temporary (:scs (descriptor-reg)) symbol value)
165 (let ((loop (gen-label))
169 (inst cmp where bsp-tn)
174 (loadw symbol bsp-tn (- binding-symbol-slot binding-size))
177 (loadw value bsp-tn (- binding-value-slot binding-size))
178 (storew value symbol symbol-value-slot other-pointer-lowtag)
179 (storew zero-tn bsp-tn (- binding-symbol-slot binding-size))
182 (inst sub bsp-tn bsp-tn (* 2 n-word-bytes))
183 (inst cmp where bsp-tn)
189 ;;;; closure indexing.
191 (define-vop (closure-index-ref word-index-ref)
192 (:variant closure-info-offset fun-pointer-lowtag)
193 (:translate %closure-index-ref))
195 (define-vop (funcallable-instance-info word-index-ref)
196 (:variant funcallable-instance-info-offset fun-pointer-lowtag)
197 (:translate %funcallable-instance-info))
199 (define-vop (set-funcallable-instance-info word-index-set)
200 (:variant funcallable-instance-info-offset fun-pointer-lowtag)
201 (:translate %set-funcallable-instance-info))
203 (define-vop (funcallable-instance-lexenv cell-ref)
204 (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
207 (define-vop (closure-ref slot-ref)
208 (:variant closure-info-offset fun-pointer-lowtag))
210 (define-vop (closure-init slot-set)
211 (:variant closure-info-offset fun-pointer-lowtag))
213 ;;;; value cell hackery.
215 (define-vop (value-cell-ref cell-ref)
216 (:variant value-cell-value-slot other-pointer-lowtag))
218 (define-vop (value-cell-set cell-set)
219 (:variant value-cell-value-slot other-pointer-lowtag))
221 ;;;; instance hackery:
223 (define-vop (instance-length)
225 (:translate %instance-length)
226 (:args (struct :scs (descriptor-reg)))
227 (:temporary (:scs (non-descriptor-reg)) temp)
228 (:results (res :scs (unsigned-reg)))
229 (:result-types positive-fixnum)
231 (loadw temp struct 0 instance-pointer-lowtag)
232 (inst srl res temp n-widetag-bits)))
234 (define-vop (instance-ref slot-ref)
235 (:variant instance-slots-offset instance-pointer-lowtag)
237 (:translate %instance-ref)
238 (:arg-types * (:constant index)))
240 ;;; This VOP has no :results; however, %instance-set must return a
241 ;;; value. This caused, in the forward port to 0.7.x, an error in
242 ;;; !fdefn-cold-init: "argument X is not a REAL: NIL". This VOP is
243 ;;; commented out for now, pending the addition of checking code to
244 ;;; the define-vop machinery to ascertain that this was indeed the
245 ;;; problem. -- CSR, 2002-02-12
247 (define-vop (instance-set slot-set)
249 (:translate %instance-set)
250 (:variant instance-slots-offset instance-pointer-lowtag)
251 (:arg-types * (:constant index) *))
253 (define-vop (instance-index-ref word-index-ref)
255 (:translate %instance-ref)
256 (:variant instance-slots-offset instance-pointer-lowtag)
257 (:arg-types * positive-fixnum))
259 (define-vop (instance-index-set word-index-set)
261 (:translate %instance-set)
262 (:variant instance-slots-offset instance-pointer-lowtag)
263 (:arg-types * positive-fixnum *))
265 ;;;; Code object frobbing.
267 (define-vop (code-header-ref word-index-ref)
268 (:translate code-header-ref)
270 (:variant 0 other-pointer-lowtag))
272 (define-vop (code-header-set word-index-set)
273 (:translate code-header-set)
275 (:variant 0 other-pointer-lowtag))