forked from dmitryvk/sbcl-win32-threads
-
Notifications
You must be signed in to change notification settings - Fork 4
/
checkgen.lisp
533 lines (499 loc) · 22.8 KB
/
checkgen.lisp
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
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
;;;; 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 (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)
((values-type-p type)
(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))
((values-type-keyp type)
*universal-type*))))
(t (weaken-type type))))
;;;; 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)
;;; CONT is a continuation 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 CONT 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 (cont types original-types force-hairy)
(declare (type continuation cont) (list types))
(multiple-value-bind (ptypes count)
(no-fun-values-types (continuation-proven-type cont))
(if (eq count :unknown)
(if (and (every #'type-check-template types) (not force-hairy))
(values :simple types)
(values :hairy (mapcar (lambda (x) (list nil x x)) types)))
(let ((res (mapcar (lambda (p c a)
(let ((diff (type-difference p c)))
(if (and diff
(< (type-test-cost diff)
(type-test-cost c))
*complement-type-checks*)
(list t diff a)
(list nil c a))))
ptypes types original-types)))
(cond ((or force-hairy (find-if #'first res))
(values :hairy res))
((every #'type-check-template types)
(values :simple types))
(t
(values :hairy res)))))))
;;; Determines whether CONT'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).
;;;
;;; A type is checkable if it either represents a fixed number of
;;; values (as determined by VALUES-TYPES), or it is the assertion for
;;; an MV-BIND. 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.
;;;
;;; 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 continuations 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 continuation, 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 CONT's 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 continuation-check-types (cont force-hairy)
(declare (type continuation cont))
(let ((ctype (continuation-type-to-check cont))
(atype (continuation-asserted-type cont))
(dest (continuation-dest cont)))
(aver (not (eq ctype *wild-type*)))
(multiple-value-bind (ctypes count) (no-fun-values-types ctype)
(multiple-value-bind (atypes acount) (no-fun-values-types atype)
(aver (eq count acount))
(cond ((not (eq count :unknown))
(if (or (exit-p dest)
(and (return-p dest)
(multiple-value-bind (ignore count)
(values-types (return-result-type dest))
(declare (ignore ignore))
(eq count :unknown))))
(maybe-negate-check cont ctypes atypes t)
(maybe-negate-check cont ctypes atypes force-hairy)))
((and (mv-combination-p dest)
(eq (basic-combination-kind dest) :local))
(aver (values-type-p ctype))
(maybe-negate-check cont
(args-type-optional ctype)
(args-type-optional atype)
force-hairy))
(t
(values :too-hairy nil)))))))
;;; Do we want to do a type check?
(defun worth-type-check-p (cont)
(let ((dest (continuation-dest cont)))
(not (or (values-subtypep (continuation-proven-type cont)
(continuation-type-to-check cont))
(and (combination-p dest)
(let ((kind (combination-kind dest)))
(or (eq kind :full)
(and (fun-info-p kind)
(null (fun-info-templates kind))
(not (fun-info-ir2-convert kind)))))
;; 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.)
(values-subtypep (continuation-externally-checkable-type cont)
(continuation-type-to-check cont)))
(and (mv-combination-p dest) ; bug 220
(eq (mv-combination-kind dest) :full))))))
;;; Return true if CONT is a continuation 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 continuation is an argument to an unknown function, or
;;; -- the continuation 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.
;;;
;;; We must only return NIL when it is *certain* that a check will not
;;; be done, since if we pass up this chance to do the check, it will
;;; be too late. The penalty for being too conservative is duplicated
;;; type checks. The penalty for erring by being too speculative is
;;; much nastier, e.g. falling through without ever being able to find
;;; an appropriate VOP.
(defun probable-type-check-p (cont)
(declare (type continuation cont))
(let ((dest (continuation-dest cont)))
(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)
((eq kind :local) t)
((eq kind :full)
(and (combination-p dest)
(not (values-subtypep ; explicit THE
(continuation-externally-checkable-type cont)
(continuation-type-to-check cont)))))
((eq kind :error) nil)
;; :ERROR means that we have an invalid syntax of
;; the call and the callee will detect it before
;; thinking about types.
((fun-info-ir2-convert kind) t)
(t
(dolist (template (fun-info-templates kind) 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 form that we can convert to do a hairy type check of the
;;; specified TYPES. TYPES is a list of the format returned by
;;; CONTINUATION-CHECK-TYPES in the :HAIRY case. In place of the
;;; actual value(s) we are to check, we use 'DUMMY. This constant
;;; reference is later replaced with the actual values continuation.
;;;
;;; 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.
;;;
;;; We can always use MULTIPLE-VALUE-BIND, since the macro is clever
;;; about binding a single variable.
(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 the node
;;; which is CONT's DEST. This code receives the value(s) that were
;;; being passed to CONT, checks the type(s) of the value(s), then
;;; passes them on to CONT.
(defun convert-type-check (cont types)
(declare (type continuation cont) (type list types))
(with-ir1-environment-from-node (continuation-dest cont)
;; Ensuring that CONT starts a block lets us freely manipulate its uses.
(ensure-block-start cont)
;; Make a new continuation and move CONT's uses to it.
(let* ((new-start (make-continuation))
(dest (continuation-dest cont))
(prev (node-prev dest)))
(continuation-starts-block new-start)
(substitute-continuation-uses new-start cont)
;; Setting TYPE-CHECK in CONT to :DELETED indicates that the
;; check has been done.
(setf (continuation-%type-check cont) :deleted)
;; Make the DEST node start its block so that we can splice in
;; the type check code.
(when (continuation-use prev)
(node-ends-block (continuation-use prev)))
(let* ((prev-block (continuation-block prev))
(new-block (continuation-block new-start))
(dummy (make-continuation)))
;; Splice in the new block before DEST, giving the new block
;; all of DEST's predecessors.
(dolist (block (block-pred prev-block))
(change-block-successor block prev-block new-block))
;; Convert the check form, using the new block start as START
;; and a dummy continuation as CONT.
(ir1-convert new-start dummy (make-type-check-form types))
;; TO DO: Why should this be true? -- WHN 19990601
(aver (eq (continuation-block dummy) new-block))
;; KLUDGE: Comments at the head of this function in CMU CL
;; said that somewhere in here we
;; Set the new block's start and end cleanups to the *start*
;; cleanup of PREV's block. This overrides the incorrect
;; default from WITH-IR1-ENVIRONMENT-FROM-NODE.
;; Unfortunately I can't find any code which corresponds to this.
;; Perhaps it was a stale comment? Or perhaps I just don't
;; understand.. -- WHN 19990521
(let ((node (continuation-use dummy)))
(setf (block-last new-block) node)
;; Change the use to a use of CONT. (We need to use the
;; dummy continuation to get the control transfer right,
;; because we want to go to PREV's block, not CONT's.)
(delete-continuation-use node)
(add-continuation-use node cont))
;; Link the new block to PREV's block.
(link-blocks new-block prev-block))
;; MAKE-TYPE-CHECK-FORM generated a form which checked the type
;; of 'DUMMY, not a real form. At this point we convert to the
;; real form by finding 'DUMMY and overwriting it with the new
;; continuation. (We can find 'DUMMY because no LET conversion
;; has been done yet.) The [mv-]combination code from the
;; mv-bind in the check form will be the use of the new check
;; continuation. We substitute for the first argument of this
;; node.
(let* ((node (continuation-use cont))
(args (basic-combination-args node))
(victim (first args)))
(aver (and (= (length args) 1)
(eq (constant-value
(ref-leaf
(continuation-use victim)))
'dummy)))
(substitute-continuation new-start victim)))
;; Invoking local call analysis converts this call to a LET.
(locall-analyze-component *current-component*))
(values))
;;; Emit a type warning for NODE. If the value of NODE 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. We
;;; ignore nodes whose type is NIL, since they are supposed to never
;;; return.
(defun emit-type-warning (node)
(declare (type node node))
(let* ((*compiler-error-context* node)
(cont (node-cont node))
(atype-spec (type-specifier (continuation-asserted-type cont)))
(dtype (node-derived-type node))
(dest (continuation-dest cont))
(what (when (and (combination-p dest)
(eq (combination-kind dest) :local))
(let ((lambda (combination-lambda dest))
(pos (position-or-lose cont (combination-args dest))))
(format nil "~:[A possible~;The~] binding of ~S"
(and (continuation-use cont)
(eq (functional-kind lambda) :let))
(leaf-source-name (elt (lambda-vars lambda)
pos)))))))
(cond ((eq dtype *empty-type*))
((and (ref-p node) (constant-p (ref-leaf node)))
(compiler-warn "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S"
what atype-spec (constant-value (ref-leaf node))))
(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 continuations 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
;;; continuation 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 a continuation 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 ((conts))
(do-blocks (block component)
(when (block-type-check block)
(do-nodes (node cont block)
(let ((type-check (continuation-type-check cont)))
(unless (member type-check '(nil :deleted))
(let ((atype (continuation-asserted-type cont)))
(do-uses (use cont)
(unless (values-types-equal-or-intersect
(node-derived-type use) atype)
(unless (policy node (= inhibit-warnings 3))
(emit-type-warning use))))))
(when (eq type-check t)
(cond ((worth-type-check-p cont)
(conts (cons cont (not (probable-type-check-p cont)))))
((probable-type-check-p cont)
(setf (continuation-%type-check cont) :deleted))
(t
(setf (continuation-%type-check cont) :no-check))))))
(setf (block-type-check block) nil)))
(dolist (cont (conts))
(destructuring-bind (cont . force-hairy) cont
(multiple-value-bind (check types)
(continuation-check-types cont force-hairy)
(ecase check
(:simple)
(:hairy
(convert-type-check cont types))
(:too-hairy
(let* ((context (continuation-dest cont))
(*compiler-error-context* context))
(when (policy context (>= safety inhibit-warnings))
(compiler-note
"type assertion too complex to check:~% ~S."
(type-specifier (continuation-asserted-type cont)))))
(setf (continuation-%type-check cont) :deleted)))))))
(values))