Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

[3d19a6]: src / compiler / checkgen.lisp Maximize Restore History

Download this file

checkgen.lisp    509 lines (488 with data), 22.2 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
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
;;;; This file implements type check generation. This is a phase that
;;;; runs at the very end of IR1. If a type check is too complex for
;;;; the back end to directly emit in-line, then we transform the check
;;;; into an explicit conditional using TYPEP.
;;;; 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!C")
;;;; cost estimation
;;; Return some sort of guess about the cost of a call to a function.
;;; If the function has some templates, we return the cost of the
;;; cheapest one, otherwise we return the cost of CALL-NAMED. Calling
;;; this with functions that have transforms can result in relatively
;;; meaningless results (exaggerated costs.)
;;;
;;; We special-case NULL, since it does have a source tranform and is
;;; interesting to us.
(defun fun-guessed-cost (name)
(declare (symbol name))
(let ((info (info :function :info name))
(call-cost (template-cost (template-or-lose 'call-named))))
(if info
(let ((templates (fun-info-templates info)))
(if templates
(template-cost (first templates))
(case name
(null (template-cost (template-or-lose 'if-eq)))
(t call-cost))))
call-cost)))
;;; Return some sort of guess for the cost of doing a test against
;;; TYPE. The result need not be precise as long as it isn't way out
;;; in space. The units are based on the costs specified for various
;;; templates in the VM definition.
(defun type-test-cost (type)
(declare (type ctype type))
(or (when (eq type *universal-type*)
0)
(when (eq type *empty-type*)
0)
(let ((check (type-check-template type)))
(if check
(template-cost check)
(let ((found (cdr (assoc type *backend-type-predicates*
:test #'type=))))
(if found
(+ (fun-guessed-cost found) (fun-guessed-cost 'eq))
nil))))
(typecase type
(compound-type
(reduce #'+ (compound-type-types type) :key 'type-test-cost))
(member-type
(* (length (member-type-members type))
(fun-guessed-cost 'eq)))
(numeric-type
(* (if (numeric-type-complexp type) 2 1)
(fun-guessed-cost
(if (csubtypep type (specifier-type 'fixnum)) 'fixnump 'numberp))
(+ 1
(if (numeric-type-low type) 1 0)
(if (numeric-type-high type) 1 0))))
(cons-type
(+ (type-test-cost (specifier-type 'cons))
(fun-guessed-cost 'car)
(type-test-cost (cons-type-car-type type))
(fun-guessed-cost 'cdr)
(type-test-cost (cons-type-cdr-type type))))
(t
(fun-guessed-cost 'typep)))))
(defun-cached
(weaken-type :hash-bits 8
:hash-function (lambda (x)
(logand (type-hash-value x) #xFF)))
((type eq))
(declare (type ctype type))
(let ((min-cost (type-test-cost type))
(min-type type)
(found-super nil))
(dolist (x *backend-type-predicates*)
(let ((stype (car x)))
(when (and (csubtypep type stype)
(not (union-type-p stype)))
(let ((stype-cost (type-test-cost stype)))
(when (or (< stype-cost min-cost)
(type= stype type))
;; If the supertype is equal in cost to the type, we
;; prefer the supertype. This produces a closer
;; approximation of the right thing in the presence of
;; poor cost info.
(setq found-super t
min-type stype
min-cost stype-cost))))))
(if found-super
min-type
*universal-type*)))
(defun weaken-values-type (type)
(declare (type ctype type))
(cond ((eq type *wild-type*) type)
((not (values-type-p type))
(weaken-type type))
(t
(make-values-type :required (mapcar #'weaken-type
(values-type-required type))
:optional (mapcar #'weaken-type
(values-type-optional type))
:rest (acond ((values-type-rest type)
(weaken-type it)))))))
;;;; checking strategy determination
;;; Return the type we should test for when we really want to check
;;; for TYPE. If type checking policy is "fast", then we return a
;;; weaker type if it is easier to check. First we try the defined
;;; type weakenings, then look for any predicate that is cheaper.
(defun maybe-weaken-check (type policy)
(declare (type ctype type))
(ecase (policy policy type-check)
(0 *wild-type*)
(2 (weaken-values-type type))
(3 type)))
;;; This is like VALUES-TYPES, only we mash any complex function types
;;; to FUNCTION.
(defun no-fun-values-types (type)
(declare (type ctype type))
(multiple-value-bind (res count) (values-types type)
(values (mapcar (lambda (type)
(if (fun-type-p type)
(specifier-type 'function)
type))
res)
count)))
;;; Switch to disable check complementing, for evaluation.
(defvar *complement-type-checks* t)
;;; LVAR is an lvar we are doing a type check on and TYPES is a list
;;; of types that we are checking its values against. If we have
;;; proven that LVAR generates a fixed number of values, then for each
;;; value, we check whether it is cheaper to then difference between
;;; the proven type and the corresponding type in TYPES. If so, we opt
;;; for a :HAIRY check with that test negated. Otherwise, we try to do
;;; a simple test, and if that is impossible, we do a hairy test with
;;; non-negated types. If true, FORCE-HAIRY forces a hairy type check.
;;;
;;; When doing a non-negated check, we call MAYBE-WEAKEN-CHECK to
;;; weaken the test to a convenient supertype (conditional on policy.)
;;; If SPEED is 3, or DEBUG-INFO is not particularly important (DEBUG
;;; <= 1), then we allow weakened checks to be simple, resulting in
;;; less informative error messages, but saving space and possibly
;;; time.
;;;
;;; FIXME: I don't quite understand this, but it looks as though
;;; that means type checks are weakened when SPEED=3 regardless of
;;; the SAFETY level, which is not the right thing to do.
(defun maybe-negate-check (lvar types original-types force-hairy n-required)
(declare (type lvar lvar) (list types original-types))
(let ((ptypes (values-type-out (lvar-derived-type lvar) (length types))))
(multiple-value-bind (hairy-res simple-res)
(loop for p in ptypes
and c in types
and a in original-types
and i from 0
for cc = (if (>= i n-required)
(type-union c (specifier-type 'null))
c)
for diff = (type-difference p cc)
collect (if (and diff
(< (type-test-cost diff)
(type-test-cost cc))
*complement-type-checks*)
(list t diff a)
(list nil cc a))
into hairy-res
collect cc into simple-res
finally (return (values hairy-res simple-res)))
(cond ((or force-hairy (find-if #'first hairy-res))
(values :hairy hairy-res))
((every #'type-check-template simple-res)
(values :simple simple-res))
(t
(values :hairy hairy-res))))))
;;; Determines whether CAST's assertion is:
;;; -- checkable by the back end (:SIMPLE), or
;;; -- not checkable by the back end, but checkable via an explicit
;;; test in type check conversion (:HAIRY), or
;;; -- not reasonably checkable at all (:TOO-HAIRY).
;;;
;;; We may check only fixed number of values; in any case the number
;;; of generated values is trusted. If we know the number of produced
;;; values, all of them are checked; otherwise if we know the number
;;; of consumed -- only they are checked; otherwise the check is not
;;; performed.
;;;
;;; A type is simply checkable if all the type assertions have a
;;; TYPE-CHECK-TEMPLATE. In this :SIMPLE case, the second value is a
;;; list of the type restrictions specified for the leading positional
;;; values.
;;;
;;; Old comment:
;;;
;;; We force a check to be hairy even when there are fixed values
;;; if we are in a context where we may be forced to use the
;;; unknown values convention anyway. This is because IR2tran can't
;;; generate type checks for unknown values lvars but people could
;;; still be depending on the check being done. We only care about
;;; EXIT and RETURN (not MV-COMBINATION) since these are the only
;;; contexts where the ultimate values receiver
;;;
;;; In the :HAIRY case, the second value is a list of triples of
;;; the form:
;;; (NOT-P TYPE ORIGINAL-TYPE)
;;;
;;; If true, the NOT-P flag indicates a test that the corresponding
;;; value is *not* of the specified TYPE. ORIGINAL-TYPE is the type
;;; asserted on this value in the lvar, for use in error
;;; messages. When NOT-P is true, this will be different from TYPE.
;;;
;;; This allows us to take what has been proven about CAST's argument
;;; type into consideration. If it is cheaper to test for the
;;; difference between the derived type and the asserted type, then we
;;; check for the negation of this type instead.
(defun cast-check-types (cast force-hairy)
(declare (type cast cast))
(let* ((ctype (coerce-to-values (cast-type-to-check cast)))
(atype (coerce-to-values (cast-asserted-type cast)))
(dtype (node-derived-type cast))
(value (cast-value cast))
(lvar (node-lvar cast))
(dest (and lvar (lvar-dest lvar)))
(n-consumed (cond ((not lvar)
nil)
((lvar-single-value-p lvar)
1)
((and (mv-combination-p dest)
(eq (mv-combination-kind dest) :local))
(let ((fun-ref (lvar-use (mv-combination-fun dest))))
(length (lambda-vars (ref-leaf fun-ref)))))))
(n-required (length (values-type-required dtype))))
(aver (not (eq ctype *wild-type*)))
(cond ((and (null (values-type-optional dtype))
(not (values-type-rest dtype)))
;; we [almost] know how many values are produced
(maybe-negate-check value
(values-type-out ctype n-required)
(values-type-out atype n-required)
;; backend checks only consumed values
(not (eql n-required n-consumed))
n-required))
((lvar-single-value-p lvar)
;; exactly one value is consumed
(principal-lvar-single-valuify lvar)
(let ((creq (car (args-type-required ctype))))
(multiple-value-setq (ctype atype)
(if creq
(values creq (car (args-type-required atype)))
(values (car (args-type-optional ctype))
(car (args-type-optional atype)))))
(maybe-negate-check value
(list ctype) (list atype)
force-hairy
n-required)))
((and (mv-combination-p dest)
(eq (mv-combination-kind dest) :local))
;; we know the number of consumed values
(maybe-negate-check value
(adjust-list (values-type-types ctype)
n-consumed
*universal-type*)
(adjust-list (values-type-types atype)
n-consumed
*universal-type*)
force-hairy
n-required))
(t
(values :too-hairy nil)))))
;;; Do we want to do a type check?
(defun cast-externally-checkable-p (cast)
(declare (type cast cast))
(let* ((lvar (node-lvar cast))
(dest (and lvar (lvar-dest lvar))))
(and (combination-p dest)
;; The theory is that the type assertion is from a
;; declaration in (or on) the callee, so the callee should be
;; able to do the check. We want to let the callee do the
;; check, because it is possible that by the time of call
;; that declaration will be changed and we do not want to
;; make people recompile all calls to a function when they
;; were originally compiled with a bad declaration. (See also
;; bug 35.)
(or (immediately-used-p lvar cast)
(binding* ((ctran (node-next cast) :exit-if-null)
(next (ctran-next ctran)))
(and (cast-p next)
(eq (node-dest next) dest)
(eq (cast-type-check next) :external))))
(values-subtypep (lvar-externally-checkable-type lvar)
(cast-type-to-check cast)))))
;;; Return true if CAST's value is an lvar whose type the back end is
;;; likely to want to check. Since we don't know what template the
;;; back end is going to choose to implement the continuation's DEST,
;;; we use a heuristic. We always return T unless:
;;; -- nobody uses the value, or
;;; -- safety is totally unimportant, or
;;; -- the lvar is an argument to an unknown function, or
;;; -- the lvar is an argument to a known function that has
;;; no IR2-CONVERT method or :FAST-SAFE templates that are
;;; compatible with the call's type.
(defun probable-type-check-p (cast)
(declare (type cast cast))
(let* ((lvar (node-lvar cast))
(dest (and lvar (lvar-dest lvar))))
(cond ((not dest) nil)
(t t))
#+nil
(cond ((or (not dest)
(policy dest (zerop safety)))
nil)
((basic-combination-p dest)
(let ((kind (basic-combination-kind dest)))
(cond
((eq cont (basic-combination-fun dest)) t)
(t
(ecase kind
(:local t)
(:full
(and (combination-p dest)
(not (values-subtypep ; explicit THE
(continuation-externally-checkable-type cont)
(continuation-type-to-check cont)))))
;; :ERROR means that we have an invalid syntax of
;; the call and the callee will detect it before
;; thinking about types.
(:error nil)
(:known
(let ((info (basic-combination-fun-info dest)))
(if (fun-info-ir2-convert info)
t
(dolist (template (fun-info-templates info) nil)
(when (eq (template-ltn-policy template)
:fast-safe)
(multiple-value-bind (val win)
(valid-fun-use dest (template-type template))
(when (or val (not win)) (return t)))))))))))))
(t t))))
;;; Return a lambda form that we can convert to do a hairy type check
;;; of the specified TYPES. TYPES is a list of the format returned by
;;; LVAR-CHECK-TYPES in the :HAIRY case.
;;;
;;; Note that we don't attempt to check for required values being
;;; unsupplied. Such checking is impossible to efficiently do at the
;;; source level because our fixed-values conventions are optimized
;;; for the common MV-BIND case.
(defun make-type-check-form (types)
(let ((temps (make-gensym-list (length types))))
`(multiple-value-bind ,temps
'dummy
,@(mapcar (lambda (temp type)
(let* ((spec
(let ((*unparse-fun-type-simplify* t))
(type-specifier (second type))))
(test (if (first type) `(not ,spec) spec)))
`(unless (typep ,temp ',test)
(%type-check-error
,temp
',(type-specifier (third type))))))
temps
types)
(values ,@temps))))
;;; Splice in explicit type check code immediately before CAST. This
;;; code receives the value(s) that were being passed to CAST-VALUE,
;;; checks the type(s) of the value(s), then passes them further.
(defun convert-type-check (cast types)
(declare (type cast cast) (type list types))
(let ((value (cast-value cast))
(length (length types)))
(filter-lvar value (make-type-check-form types))
(reoptimize-lvar (cast-value cast))
(setf (cast-type-to-check cast) *wild-type*)
(setf (cast-%type-check cast) nil)
(let* ((atype (cast-asserted-type cast))
(atype (cond ((not (values-type-p atype))
atype)
((= length 1)
(single-value-type atype))
(t
(make-values-type
:required (values-type-out atype length)))))
(dtype (node-derived-type cast))
(dtype (make-values-type
:required (values-type-out dtype length))))
(setf (cast-asserted-type cast) atype)
(setf (node-derived-type cast) dtype)))
(values))
;;; Check all possible arguments of CAST and emit type warnings for
;;; those with type errors. If the value of USE is being used for a
;;; variable binding, we figure out which one for source context. If
;;; the value is a constant, we print it specially.
(defun cast-check-uses (cast)
(declare (type cast cast))
(let* ((lvar (node-lvar cast))
(dest (and lvar (lvar-dest lvar)))
(value (cast-value cast))
(atype (cast-asserted-type cast)))
(do-uses (use value)
(let ((dtype (node-derived-type use)))
(unless (values-types-equal-or-intersect dtype atype)
(let* ((*compiler-error-context* use)
(atype-spec (type-specifier atype))
(what (when (and (combination-p dest)
(eq (combination-kind dest) :local))
(let ((lambda (combination-lambda dest))
(pos (position-or-lose
lvar (combination-args dest))))
(format nil "~:[A possible~;The~] binding of ~S"
(and (lvar-has-single-use-p lvar)
(eq (functional-kind lambda) :let))
(leaf-source-name (elt (lambda-vars lambda)
pos)))))))
(cond ((and (ref-p use) (constant-p (ref-leaf use)))
(compiler-warn "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S"
what atype-spec (constant-value (ref-leaf use))))
(t
(compiler-warn
"~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
what (type-specifier dtype) atype-spec))))))))
(values))
;;; Loop over all blocks in COMPONENT that have TYPE-CHECK set,
;;; looking for CASTs with TYPE-CHECK T. We do two mostly unrelated
;;; things: detect compile-time type errors and determine if and how
;;; to do run-time type checks.
;;;
;;; If there is a compile-time type error, then we mark the CAST and
;;; emit a warning if appropriate. This part loops over all the uses
;;; of the continuation, since after we convert the check, the
;;; :DELETED kind will inhibit warnings about the types of other uses.
;;;
;;; If the cast is too complex to be checked by the back end, or is
;;; better checked with explicit code, then convert to an explicit
;;; test. Assertions that can checked by the back end are passed
;;; through. Assertions that can't be tested are flamed about and
;;; marked as not needing to be checked.
;;;
;;; If we determine that a type check won't be done, then we set
;;; TYPE-CHECK to :NO-CHECK. In the non-hairy cases, this is just to
;;; prevent us from wasting time coming to the same conclusion again
;;; on a later iteration. In the hairy case, we must indicate to LTN
;;; that it must choose a safe implementation, since IR2 conversion
;;; will choke on the check.
;;;
;;; The generation of the type checks is delayed until all the type
;;; check decisions have been made because the generation of the type
;;; checks creates new nodes whose derived types aren't always updated
;;; which may lead to inappropriate template choices due to the
;;; modification of argument types.
(defun generate-type-checks (component)
(collect ((casts))
(do-blocks (block component)
(when (block-type-check block)
;; CAST-EXTERNALLY-CHECKABLE-P wants the backward pass
(do-nodes-backwards (node nil block)
(when (and (cast-p node)
(cast-type-check node))
(cast-check-uses node)
(cond ((cast-externally-checkable-p node)
(setf (cast-%type-check node) :external))
(t
;; it is possible that NODE was marked :EXTERNAL by
;; the previous pass
(setf (cast-%type-check node) t)
(casts (cons node (not (probable-type-check-p node))))))))
(setf (block-type-check block) nil)))
(dolist (cast (casts))
(destructuring-bind (cast . force-hairy) cast
(multiple-value-bind (check types)
(cast-check-types cast force-hairy)
(ecase check
(:simple)
(:hairy
(convert-type-check cast types))
(:too-hairy
(let ((*compiler-error-context* cast))
(when (policy cast (>= safety inhibit-warnings))
(compiler-notify
"type assertion too complex to check:~% ~S."
(type-specifier (coerce-to-values (cast-asserted-type cast))))))
(setf (cast-type-to-check cast) *wild-type*)
(setf (cast-%type-check cast) nil)))))))
(values))