[506253]: src / compiler / ppc / cell.lisp Maximize Restore History

Download this file

cell.lisp    281 lines (219 with data), 8.8 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
;;; VOPs for the PPC.
;;;
;;; Written by Rob MacLachlan
;;;
;;; Converted by William Lott.
;;;
(in-package "SB!VM")
;;;; Data object ref/set stuff.
(define-vop (slot)
(:args (object :scs (descriptor-reg)))
(:info name offset lowtag)
(:ignore name)
(:results (result :scs (descriptor-reg any-reg)))
(:generator 1
(loadw result object offset lowtag)))
(define-vop (set-slot)
(:args (object :scs (descriptor-reg))
(value :scs (descriptor-reg any-reg)))
(:info name offset lowtag)
(:ignore name)
(:results)
(:generator 1
(storew value object offset lowtag)))
;;;; Symbol hacking VOPs:
;;; The compiler likes to be able to directly SET symbols.
;;;
(define-vop (set cell-set)
(:variant symbol-value-slot other-pointer-lowtag))
;;; Do a cell ref with an error check for being unbound.
;;;
(define-vop (checked-cell-ref)
(:args (object :scs (descriptor-reg) :target obj-temp))
(:results (value :scs (descriptor-reg any-reg)))
(:policy :fast-safe)
(:vop-var vop)
(:save-p :compute-only)
(:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp))
;;; With Symbol-Value, we check that the value isn't the trap object. So
;;; Symbol-Value of NIL is NIL.
;;;
(define-vop (symbol-value checked-cell-ref)
(:translate symbol-value)
(:generator 9
(move obj-temp object)
(loadw value obj-temp sb!vm:symbol-value-slot sb!vm:other-pointer-lowtag)
(let ((err-lab (generate-error-code vop unbound-symbol-error obj-temp)))
(inst cmpwi value sb!vm:unbound-marker-widetag)
(inst beq err-lab))))
;;; Like CHECKED-CELL-REF, only we are a predicate to see if the cell is bound.
(define-vop (boundp-frob)
(:args (object :scs (descriptor-reg)))
(:conditional)
(:info target not-p)
(:policy :fast-safe)
(:temporary (:scs (descriptor-reg)) value))
(define-vop (boundp boundp-frob)
(:translate boundp)
(:generator 9
(loadw value object sb!vm:symbol-value-slot sb!vm:other-pointer-lowtag)
(inst cmpwi value sb!vm:unbound-marker-widetag)
(inst b? (if not-p :eq :ne) target)))
(define-vop (fast-symbol-value cell-ref)
(:variant sb!vm:symbol-value-slot sb!vm:other-pointer-lowtag)
(:policy :fast)
(:translate symbol-value))
;;;; Fdefinition (fdefn) objects.
(define-vop (fdefn-fun cell-ref)
(:variant fdefn-fun-slot other-pointer-lowtag))
(define-vop (safe-fdefn-fun)
(:args (object :scs (descriptor-reg) :target obj-temp))
(:results (value :scs (descriptor-reg any-reg)))
(:vop-var vop)
(:save-p :compute-only)
(:temporary (:scs (descriptor-reg) :from (:argument 0)) obj-temp)
(:generator 10
(move obj-temp object)
(loadw value obj-temp fdefn-fun-slot other-pointer-lowtag)
(inst cmpw value null-tn)
(let ((err-lab (generate-error-code vop undefined-fun-error obj-temp)))
(inst beq err-lab))))
(define-vop (set-fdefn-fun)
(:policy :fast-safe)
(:translate (setf fdefn-fun))
(:args (function :scs (descriptor-reg) :target result)
(fdefn :scs (descriptor-reg)))
(:temporary (:scs (interior-reg)) lip)
(:temporary (:scs (non-descriptor-reg)) type)
(:results (result :scs (descriptor-reg)))
(:generator 38
(let ((normal-fn (gen-label)))
(load-type type function (- fun-pointer-lowtag))
(inst cmpwi type simple-fun-header-widetag)
;;(inst mr lip function)
(inst addi lip function
(- (ash simple-fun-code-offset word-shift) fun-pointer-lowtag))
(inst beq normal-fn)
(inst lr lip (make-fixup (extern-alien-name "closure_tramp") :foreign))
(emit-label normal-fn)
(storew lip fdefn fdefn-raw-addr-slot other-pointer-lowtag)
(storew function fdefn fdefn-fun-slot other-pointer-lowtag)
(move result function))))
(define-vop (fdefn-makunbound)
(:policy :fast-safe)
(:translate fdefn-makunbound)
(:args (fdefn :scs (descriptor-reg) :target result))
(:temporary (:scs (non-descriptor-reg)) temp)
(:results (result :scs (descriptor-reg)))
(:generator 38
(storew null-tn fdefn fdefn-fun-slot other-pointer-lowtag)
(inst lr temp (make-fixup (extern-alien-name "undefined_tramp") :foreign))
(storew temp fdefn fdefn-raw-addr-slot other-pointer-lowtag)
(move result fdefn)))
;;;; Binding and Unbinding.
;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
;;; the symbol on the binding stack and stuff the new value into the
;;; symbol.
(define-vop (bind)
(:args (val :scs (any-reg descriptor-reg))
(symbol :scs (descriptor-reg)))
(:temporary (:scs (descriptor-reg)) temp)
(:generator 5
(loadw temp symbol sb!vm:symbol-value-slot sb!vm:other-pointer-lowtag)
(inst addi bsp-tn bsp-tn (* 2 sb!vm:n-word-bytes))
(storew temp bsp-tn (- sb!vm:binding-value-slot sb!vm:binding-size))
(storew symbol bsp-tn (- sb!vm:binding-symbol-slot sb!vm:binding-size))
(storew val symbol sb!vm:symbol-value-slot sb!vm:other-pointer-lowtag)))
(define-vop (unbind)
(:temporary (:scs (descriptor-reg)) symbol value)
(:generator 0
(loadw symbol bsp-tn (- sb!vm:binding-symbol-slot sb!vm:binding-size))
(loadw value bsp-tn (- sb!vm:binding-value-slot sb!vm:binding-size))
(storew value symbol sb!vm:symbol-value-slot sb!vm:other-pointer-lowtag)
(storew zero-tn bsp-tn (- sb!vm:binding-symbol-slot sb!vm:binding-size))
(inst subi bsp-tn bsp-tn (* 2 sb!vm:n-word-bytes))))
(define-vop (unbind-to-here)
(:args (arg :scs (descriptor-reg any-reg) :target where))
(:temporary (:scs (any-reg) :from (:argument 0)) where)
(:temporary (:scs (descriptor-reg)) symbol value)
(:generator 0
(let ((loop (gen-label))
(skip (gen-label))
(done (gen-label)))
(move where arg)
(inst cmpw where bsp-tn)
(inst beq done)
(emit-label loop)
(loadw symbol bsp-tn (- sb!vm:binding-symbol-slot sb!vm:binding-size))
(inst cmpwi symbol 0)
(inst beq skip)
(loadw value bsp-tn (- sb!vm:binding-value-slot sb!vm:binding-size))
(storew value symbol sb!vm:symbol-value-slot sb!vm:other-pointer-lowtag)
(storew zero-tn bsp-tn (- sb!vm:binding-symbol-slot sb!vm:binding-size))
(emit-label skip)
(inst subi bsp-tn bsp-tn (* 2 sb!vm:n-word-bytes))
(inst cmpw where bsp-tn)
(inst bne loop)
(emit-label done))))
;;;; Closure indexing.
(define-vop (closure-index-ref word-index-ref)
(:variant sb!vm:closure-info-offset sb!vm:fun-pointer-lowtag)
(:translate %closure-index-ref))
(define-vop (funcallable-instance-info word-index-ref)
(:variant funcallable-instance-info-offset sb!vm:fun-pointer-lowtag)
(:translate %funcallable-instance-info))
(define-vop (set-funcallable-instance-info word-index-set)
(:variant funcallable-instance-info-offset fun-pointer-lowtag)
(:translate %set-funcallable-instance-info))
(define-vop (funcallable-instance-lexenv cell-ref)
(:variant funcallable-instance-lexenv-slot fun-pointer-lowtag))
(define-vop (closure-ref slot-ref)
(:variant closure-info-offset fun-pointer-lowtag))
(define-vop (closure-init slot-set)
(:variant closure-info-offset fun-pointer-lowtag))
;;;; Value Cell hackery.
(define-vop (value-cell-ref cell-ref)
(:variant value-cell-value-slot other-pointer-lowtag))
(define-vop (value-cell-set cell-set)
(:variant value-cell-value-slot other-pointer-lowtag))
;;;; Instance hackery:
(define-vop (instance-length)
(:policy :fast-safe)
(:translate %instance-length)
(:args (struct :scs (descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:results (res :scs (unsigned-reg)))
(:result-types positive-fixnum)
(:generator 4
(loadw temp struct 0 instance-pointer-lowtag)
(inst srwi res temp sb!vm:n-widetag-bits)))
(define-vop (instance-ref slot-ref)
(:variant instance-slots-offset instance-pointer-lowtag)
(:policy :fast-safe)
(:translate %instance-ref)
(:arg-types * (:constant index)))
#+nil
(define-vop (instance-set slot-set)
(:policy :fast-safe)
(:translate %instance-set)
(:variant instance-slots-offset instance-pointer-lowtag)
(:arg-types instance (:constant index) *))
(define-vop (instance-index-ref word-index-ref)
(:policy :fast-safe)
(:translate %instance-ref)
(:variant instance-slots-offset instance-pointer-lowtag)
(:arg-types instance positive-fixnum))
(define-vop (instance-index-set word-index-set)
(:policy :fast-safe)
(:translate %instance-set)
(:variant instance-slots-offset instance-pointer-lowtag)
(:arg-types instance positive-fixnum *))
;;;; Code object frobbing.
(define-vop (code-header-ref word-index-ref)
(:translate code-header-ref)
(:policy :fast-safe)
(:variant 0 other-pointer-lowtag))
(define-vop (code-header-set word-index-set)
(:translate code-header-set)
(:policy :fast-safe)
(:variant 0 other-pointer-lowtag))