1 ;;;; various primitive memory access VOPs for the x86 VM
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 ;;;; 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 immediate)))
27 (:info name offset lowtag)
31 (if (sc-is value immediate)
32 (let ((val (tn-value value)))
36 (make-ea :dword :base object
37 :disp (- (* offset n-word-bytes) lowtag))
41 (make-ea :dword :base object
42 :disp (- (* offset n-word-bytes) lowtag))
43 (+ nil-value (static-symbol-offset val))))
46 (make-ea :dword :base object
47 :disp (- (* offset n-word-bytes) lowtag))
48 (logior (ash (char-code val) n-widetag-bits)
49 base-char-widetag)))))
50 ;; Else, value not immediate.
51 (storew value object offset lowtag))))
53 ;;;; symbol hacking VOPs
55 ;;; these next two cf the sparc version, by jrd.
56 ;;; FIXME: Deref this ^ reference.
58 ;;; The compiler likes to be able to directly SET symbols.
59 (define-vop (set cell-set)
60 (:variant symbol-value-slot other-pointer-lowtag))
62 ;;; Do a cell ref with an error check for being unbound.
63 (define-vop (checked-cell-ref)
64 (:args (object :scs (descriptor-reg) :target obj-temp))
65 (:results (value :scs (descriptor-reg any-reg)))
68 (:save-p :compute-only)
69 (:temporary (:sc descriptor-reg :from (:argument 0)) obj-temp))
71 ;;; With Symbol-Value, we check that the value isn't the trap object. So
72 ;;; Symbol-Value of NIL is NIL.
73 (define-vop (symbol-value)
74 (:translate symbol-value)
76 (:args (object :scs (descriptor-reg) :to (:result 1)))
77 (:results (value :scs (descriptor-reg any-reg)))
79 (:save-p :compute-only)
81 (let ((err-lab (generate-error-code vop unbound-symbol-error object)))
82 (loadw value object symbol-value-slot other-pointer-lowtag)
83 (inst cmp value unbound-marker-widetag)
84 (inst jmp :e err-lab))))
86 (define-vop (fast-symbol-value cell-ref)
87 (:variant symbol-value-slot other-pointer-lowtag)
89 (:translate symbol-value))
91 (defknown fast-symbol-value-xadd (symbol fixnum) fixnum ())
92 (define-vop (fast-symbol-value-xadd cell-xadd)
93 (:variant symbol-value-slot other-pointer-lowtag)
95 (:translate fast-symbol-value-xadd)
96 (:arg-types * tagged-num))
101 (:args (object :scs (descriptor-reg)))
104 (:temporary (:sc descriptor-reg :from (:argument 0)) value)
106 (loadw value object symbol-value-slot other-pointer-lowtag)
107 (inst cmp value unbound-marker-widetag)
108 (inst jmp (if not-p :e :ne) target)))
110 (define-vop (symbol-hash)
112 (:translate symbol-hash)
113 (:args (symbol :scs (descriptor-reg)))
114 (:results (res :scs (any-reg)))
115 (:result-types positive-fixnum)
117 ;; The symbol-hash slot of NIL holds NIL because it is also the
118 ;; cdr slot, so we have to strip off the two low bits to make sure
119 ;; it is a fixnum. The lowtag selection magic that is required to
120 ;; ensure this is explained in the comment in objdef.lisp
121 (loadw res symbol symbol-hash-slot other-pointer-lowtag)
122 (inst and res (lognot #b11))))
124 ;;;; fdefinition (FDEFN) objects
126 (define-vop (fdefn-fun cell-ref) ; /pfw - alpha
127 (:variant fdefn-fun-slot other-pointer-lowtag))
129 (define-vop (safe-fdefn-fun)
130 (:args (object :scs (descriptor-reg) :to (:result 1)))
131 (:results (value :scs (descriptor-reg any-reg)))
133 (:save-p :compute-only)
135 (loadw value object fdefn-fun-slot other-pointer-lowtag)
136 (inst cmp value nil-value)
137 (let ((err-lab (generate-error-code vop undefined-fun-error object)))
138 (inst jmp :e err-lab))))
140 (define-vop (set-fdefn-fun)
142 (:translate (setf fdefn-fun))
143 (:args (function :scs (descriptor-reg) :target result)
144 (fdefn :scs (descriptor-reg)))
145 (:temporary (:sc unsigned-reg) raw)
146 (:temporary (:sc byte-reg) type)
147 (:results (result :scs (descriptor-reg)))
149 (load-type type function (- fun-pointer-lowtag))
151 (make-ea :byte :base function
152 :disp (- (* simple-fun-code-offset n-word-bytes)
153 fun-pointer-lowtag)))
154 (inst cmp type simple-fun-header-widetag)
155 (inst jmp :e normal-fn)
156 (inst lea raw (make-fixup (extern-alien-name "closure_tramp") :foreign))
158 (storew function fdefn fdefn-fun-slot other-pointer-lowtag)
159 (storew raw fdefn fdefn-raw-addr-slot other-pointer-lowtag)
160 (move result function)))
162 (define-vop (fdefn-makunbound)
164 (:translate fdefn-makunbound)
165 (:args (fdefn :scs (descriptor-reg) :target result))
166 (:results (result :scs (descriptor-reg)))
168 (storew nil-value fdefn fdefn-fun-slot other-pointer-lowtag)
169 (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
170 fdefn fdefn-raw-addr-slot other-pointer-lowtag)
171 (move result fdefn)))
173 ;;;; binding and unbinding
175 ;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
176 ;;; the symbol on the binding stack and stuff the new value into the
180 (:args (val :scs (any-reg descriptor-reg))
181 (symbol :scs (descriptor-reg)))
182 (:temporary (:sc unsigned-reg) temp bsp)
184 (load-symbol-value bsp *binding-stack-pointer*)
185 (loadw temp symbol symbol-value-slot other-pointer-lowtag)
186 (inst add bsp (* binding-size n-word-bytes))
187 (store-symbol-value bsp *binding-stack-pointer*)
188 (storew temp bsp (- binding-value-slot binding-size))
189 (storew symbol bsp (- binding-symbol-slot binding-size))
190 (storew val symbol symbol-value-slot other-pointer-lowtag)))
193 (:temporary (:sc unsigned-reg) symbol value bsp)
195 (load-symbol-value bsp *binding-stack-pointer*)
196 (loadw symbol bsp (- binding-symbol-slot binding-size))
197 (loadw value bsp (- binding-value-slot binding-size))
198 (storew value symbol symbol-value-slot other-pointer-lowtag)
199 (storew 0 bsp (- binding-symbol-slot binding-size))
200 (inst sub bsp (* binding-size n-word-bytes))
201 (store-symbol-value bsp *binding-stack-pointer*)))
203 (define-vop (unbind-to-here)
204 (:args (where :scs (descriptor-reg any-reg)))
205 (:temporary (:sc unsigned-reg) symbol value bsp)
207 (load-symbol-value bsp *binding-stack-pointer*)
212 (loadw symbol bsp (- binding-symbol-slot binding-size))
213 (inst or symbol symbol)
215 (loadw value bsp (- binding-value-slot binding-size))
216 (storew value symbol symbol-value-slot other-pointer-lowtag)
217 (storew 0 bsp (- binding-symbol-slot binding-size))
220 (inst sub bsp (* binding-size n-word-bytes))
223 (store-symbol-value bsp *binding-stack-pointer*)
227 ;;;; closure indexing
229 (define-full-reffer closure-index-ref *
230 closure-info-offset fun-pointer-lowtag
231 (any-reg descriptor-reg) * %closure-index-ref)
233 (define-full-setter set-funcallable-instance-info *
234 funcallable-instance-info-offset fun-pointer-lowtag
235 (any-reg descriptor-reg) * %set-funcallable-instance-info)
237 (define-full-reffer funcallable-instance-info *
238 funcallable-instance-info-offset fun-pointer-lowtag
239 (descriptor-reg any-reg) * %funcallable-instance-info)
241 (define-vop (funcallable-instance-lexenv cell-ref)
242 (:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
244 (define-vop (closure-ref slot-ref)
245 (:variant closure-info-offset fun-pointer-lowtag))
247 (define-vop (closure-init slot-set)
248 (:variant closure-info-offset fun-pointer-lowtag))
250 ;;;; value cell hackery
252 (define-vop (value-cell-ref cell-ref)
253 (:variant value-cell-value-slot other-pointer-lowtag))
255 (define-vop (value-cell-set cell-set)
256 (:variant value-cell-value-slot other-pointer-lowtag))
258 ;;;; structure hackery
260 (define-vop (instance-length)
262 (:translate %instance-length)
263 (:args (struct :scs (descriptor-reg)))
264 (:results (res :scs (unsigned-reg)))
265 (:result-types positive-fixnum)
267 (loadw res struct 0 instance-pointer-lowtag)
268 (inst shr res n-widetag-bits)))
270 (define-vop (instance-ref slot-ref)
271 (:variant instance-slots-offset instance-pointer-lowtag)
273 (:translate %instance-ref)
274 (:arg-types instance (:constant index)))
276 (define-vop (instance-set slot-set)
278 (:translate %instance-set)
279 (:variant instance-slots-offset instance-pointer-lowtag)
280 (:arg-types instance (:constant index) *))
282 (define-full-reffer instance-index-ref * instance-slots-offset
283 instance-pointer-lowtag (any-reg descriptor-reg) * %instance-ref)
285 (define-full-setter instance-index-set * instance-slots-offset
286 instance-pointer-lowtag (any-reg descriptor-reg) * %instance-set)
288 ;;;; code object frobbing
290 (define-full-reffer code-header-ref * 0 other-pointer-lowtag
291 (any-reg descriptor-reg) * code-header-ref)
293 (define-full-setter code-header-set * 0 other-pointer-lowtag
294 (any-reg descriptor-reg) * code-header-set)