[3d19a6]: src / compiler / ppc / type-vops.lisp Maximize Restore History

Download this file

type-vops.lisp    327 lines (290 with data), 11.0 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
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
;;;; type testing and checking VOPs for the PPC VM
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!VM")
(defun %test-fixnum (value target not-p &key temp)
(assemble ()
(inst andi. temp value fixnum-tag-mask)
(inst b? (if not-p :ne :eq) target)))
(defun %test-fixnum-and-headers (value target not-p headers &key temp)
(let ((drop-through (gen-label)))
(assemble ()
(inst andi. temp value fixnum-tag-mask)
(inst beq (if not-p drop-through target)))
(%test-headers value target not-p nil headers
:drop-through drop-through :temp temp)))
(defun %test-immediate (value target not-p immediate &key temp)
(assemble ()
(inst andi. temp value widetag-mask)
(inst cmpwi temp immediate)
(inst b? (if not-p :ne :eq) target)))
(defun %test-lowtag (value target not-p lowtag &key temp)
(assemble ()
(inst andi. temp value lowtag-mask)
(inst cmpwi temp lowtag)
(inst b? (if not-p :ne :eq) target)))
(defun %test-headers (value target not-p function-p headers
&key temp (drop-through (gen-label)))
(let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
(multiple-value-bind (when-true when-false)
(if not-p
(values drop-through target)
(values target drop-through))
(assemble ()
(%test-lowtag value when-false t lowtag :temp temp)
(load-type temp value (- lowtag))
(do ((remaining headers (cdr remaining)))
((null remaining))
(let ((header (car remaining))
(last (null (cdr remaining))))
(cond
((atom header)
(cond
((and (not last) (null (cddr remaining))
(atom (cadr remaining))
(= (logcount (logxor header (cadr remaining))) 1))
(inst andi. temp temp (ldb (byte 8 0) (logeqv header (cadr remaining))))
(inst cmpwi temp (ldb (byte 8 0) (logand header (cadr remaining))))
(inst b? (if not-p :ne :eq) target)
(return))
(t
(inst cmpwi temp header)
(if last
(inst b? (if not-p :ne :eq) target)
(inst beq when-true)))))
(t
(let ((start (car header))
(end (cdr header)))
(cond
((and last (not (= start bignum-widetag))
(= (+ start 4) end)
(= (logcount (logxor start end)) 1))
(inst andi. temp temp (ldb (byte 8 0) (logeqv start end)))
(inst cmpwi temp (ldb (byte 8 0) (logand start end)))
(inst b? (if not-p :ne :eq) target))
((and (not last) (null (cddr remaining))
(= (+ start 4) end) (= (logcount (logxor start end)) 1)
(listp (cadr remaining))
(= (+ (caadr remaining) 4) (cdadr remaining))
(= (logcount (logxor (caadr remaining) (cdadr remaining))) 1)
(= (logcount (logxor (caadr remaining) start)) 1))
(inst andi. temp temp (ldb (byte 8 0) (logeqv start (cdadr remaining))))
(inst cmpwi temp (ldb (byte 8 0) (logand start (cdadr remaining))))
(inst b? (if not-p :ne :eq) target)
(return))
(t
(unless (= start bignum-widetag)
(inst cmpwi temp start)
(if (= end complex-array-widetag)
(progn
(aver last)
(inst b? (if not-p :lt :ge) target))
(inst blt when-false)))
(unless (= end complex-array-widetag)
(inst cmpwi temp end)
(if last
(inst b? (if not-p :gt :le) target)
(inst ble when-true))))))))))
(emit-label drop-through)))))
;;; Simple type checking and testing:
(define-vop (check-type)
(:args (value :target result :scs (any-reg descriptor-reg)))
(:results (result :scs (any-reg descriptor-reg)))
(:temporary (:scs (non-descriptor-reg)) temp)
(:vop-var vop)
(:save-p :compute-only))
(define-vop (type-predicate)
(:args (value :scs (any-reg descriptor-reg)))
(:conditional)
(:info target not-p)
(:policy :fast-safe)
(:temporary (:scs (non-descriptor-reg)) temp))
(defun cost-to-test-types (type-codes)
(+ (* 2 (length type-codes))
(if (> (apply #'max type-codes) lowtag-limit) 7 2)))
(defmacro !define-type-vops (pred-name check-name ptype error-code
(&rest type-codes)
;; KLUDGE: ideally, the compiler could
;; derive that it can use the sneaky trap
;; twice mechanism itself. However, one
;; thing at a time...
&key mask &allow-other-keys)
(let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
`(progn
,@(when pred-name
`((define-vop (,pred-name type-predicate)
(:translate ,pred-name)
(:generator ,cost
(test-type value target not-p (,@type-codes) :temp temp)))))
,@(when check-name
`((define-vop (,check-name check-type)
(:generator ,cost
,@(if mask
`((inst andi. temp value ,mask)
(inst twi 0 value (error-number-or-lose ',error-code))
(inst twi :ne temp ,@(ecase mask
((fixnum-tag-mask) `(0))
((lowtag-mask) type-codes)))
(move result value))
`((let ((err-lab
(generate-error-code vop ,error-code value)))
(test-type value err-lab t (,@type-codes) :temp temp)
(move result value))))))))
,@(when ptype
`((primitive-type-vop ,check-name (:check) ,ptype))))))
;;;; Other integer ranges.
;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
;;; exactly one digit.
(define-vop (signed-byte-32-p type-predicate)
(:translate signed-byte-32-p)
(:generator 45
(let ((not-target (gen-label)))
(multiple-value-bind
(yep nope)
(if not-p
(values not-target target)
(values target not-target))
(inst andi. temp value #x3)
(inst beq yep)
(test-type value nope t (other-pointer-lowtag) :temp temp)
(loadw temp value 0 other-pointer-lowtag)
(inst cmpwi temp (+ (ash 1 n-widetag-bits)
bignum-widetag))
(inst b? (if not-p :ne :eq) target)
(emit-label not-target)))))
(define-vop (check-signed-byte-32 check-type)
(:generator 45
(let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
(yep (gen-label)))
(inst andi. temp value #x3)
(inst beq yep)
(test-type value nope t (other-pointer-lowtag) :temp temp)
(loadw temp value 0 other-pointer-lowtag)
(inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
(inst bne nope)
(emit-label yep)
(move result value))))
;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
;;; bignum with exactly one positive digit, or a bignum with exactly two digits
;;; and the second digit all zeros.
(define-vop (unsigned-byte-32-p type-predicate)
(:translate unsigned-byte-32-p)
(:generator 45
(let ((not-target (gen-label))
(single-word (gen-label))
(fixnum (gen-label)))
(multiple-value-bind
(yep nope)
(if not-p
(values not-target target)
(values target not-target))
;; Is it a fixnum?
(inst andi. temp value #x3)
(inst cmpwi :cr1 value 0)
(inst beq fixnum)
;; If not, is it an other pointer?
(test-type value nope t (other-pointer-lowtag) :temp temp)
;; Get the header.
(loadw temp value 0 other-pointer-lowtag)
;; Is it one?
(inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
(inst beq single-word)
;; If it's other than two, we can't be an (unsigned-byte 32)
(inst cmpwi temp (+ (ash 2 n-widetag-bits) bignum-widetag))
(inst bne nope)
;; Get the second digit.
(loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
;; All zeros, its an (unsigned-byte 32).
(inst cmpwi temp 0)
(inst beq yep)
;; Otherwise, it isn't.
(inst b nope)
(emit-label single-word)
;; Get the single digit.
(loadw temp value bignum-digits-offset other-pointer-lowtag)
(inst cmpwi :cr1 temp 0)
;; positive implies (unsigned-byte 32).
(emit-label fixnum)
(inst b? :cr1 (if not-p :lt :ge) target)
(emit-label not-target)))))
(define-vop (check-unsigned-byte-32 check-type)
(:generator 45
(let ((nope
(generate-error-code vop object-not-unsigned-byte-32-error value))
(yep (gen-label))
(fixnum (gen-label))
(single-word (gen-label)))
;; Is it a fixnum?
(inst andi. temp value #x3)
(inst cmpwi :cr1 value 0)
(inst beq fixnum)
;; If not, is it an other pointer?
(test-type value nope t (other-pointer-lowtag) :temp temp)
;; Get the number of digits.
(loadw temp value 0 other-pointer-lowtag)
;; Is it one?
(inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
(inst beq single-word)
;; If it's other than two, we can't be an (unsigned-byte 32)
(inst cmpwi temp (+ (ash 2 n-widetag-bits) bignum-widetag))
(inst bne nope)
;; Get the second digit.
(loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
;; All zeros, its an (unsigned-byte 32).
(inst cmpwi temp 0)
(inst beq yep)
;; Otherwise, it isn't.
(inst b nope)
(emit-label single-word)
;; Get the single digit.
(loadw temp value bignum-digits-offset other-pointer-lowtag)
;; positive implies (unsigned-byte 32).
(inst cmpwi :cr1 temp 0)
(emit-label fixnum)
(inst blt :cr1 nope)
(emit-label yep)
(move result value))))
;;;; List/symbol types:
;;;
;;; symbolp (or symbol (eq nil))
;;; consp (and list (not (eq nil)))
(define-vop (symbolp type-predicate)
(:translate symbolp)
(:generator 12
(let* ((drop-thru (gen-label))
(is-symbol-label (if not-p drop-thru target)))
(inst cmpw value null-tn)
(inst beq is-symbol-label)
(test-type value target not-p (symbol-header-widetag) :temp temp)
(emit-label drop-thru))))
(define-vop (check-symbol check-type)
(:generator 12
(let ((drop-thru (gen-label))
(error (generate-error-code vop object-not-symbol-error value)))
(inst cmpw value null-tn)
(inst beq drop-thru)
(test-type value error t (symbol-header-widetag) :temp temp)
(emit-label drop-thru)
(move result value))))
(define-vop (consp type-predicate)
(:translate consp)
(:generator 8
(let* ((drop-thru (gen-label))
(is-not-cons-label (if not-p target drop-thru)))
(inst cmpw value null-tn)
(inst beq is-not-cons-label)
(test-type value target not-p (list-pointer-lowtag) :temp temp)
(emit-label drop-thru))))
(define-vop (check-cons check-type)
(:generator 8
(let ((error (generate-error-code vop object-not-cons-error value)))
(inst cmpw value null-tn)
(inst beq error)
(test-type value error t (list-pointer-lowtag) :temp temp)
(move result value))))