/[cmucl]/src/compiler/checkgen.lisp
ViewVC logotype

Diff of /src/compiler/checkgen.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.12 by ram, Wed Sep 5 15:33:31 1990 UTC revision 1.13 by ram, Thu Oct 11 17:22:17 1990 UTC
# Line 142  Line 142 
142  ;;; whether it is cheaper to then difference between the the proven type and  ;;; whether it is cheaper to then difference between the the proven type and
143  ;;; the corresponding type in Types.  If so, we opt for a :HAIRY check with  ;;; the corresponding type in Types.  If so, we opt for a :HAIRY check with
144  ;;; that test negated.  Otherwise, we try to do a simple test, and if that is  ;;; that test negated.  Otherwise, we try to do a simple test, and if that is
145  ;;; impossible, we do a hairy test with non-negated types.  ;;; impossible, we do a hairy test with non-negated types.  If true,
146    ;;; Force-Hairy forces a hairy type check.
147  ;;;  ;;;
148  ;;;    When doing a non-negated hairy check, we call MAYBE-WEAKEN-CHECK to  ;;;    When doing a non-negated hairy check, we call MAYBE-WEAKEN-CHECK to
149  ;;; weaken the test to a convenient supertype (conditional on policy.)  ;;; weaken the test to a convenient supertype (conditional on policy.)
150  ;;;  ;;;
151  (defun maybe-negate-check (cont types)  (defun maybe-negate-check (cont types force-hairy)
152    (declare (type continuation cont) (list types))    (declare (type continuation cont) (list types))
153    (multiple-value-bind    (multiple-value-bind
154        (ptypes count)        (ptypes count)
155        (no-function-values-types (continuation-proven-type cont))        (no-function-values-types (continuation-proven-type cont))
156      (if (eq count :unknown)      (if (eq count :unknown)
157          (if (every #'type-check-template types)          (if (and (every #'type-check-template types) (not force-hairy))
158              (values :simple types)              (values :simple types)
159              (values :hairy              (values :hairy
160                      (mapcar #'(lambda (x)                      (mapcar #'(lambda (x)
# Line 169  Line 170 
170                                       (list nil weak c))))                                       (list nil weak c))))
171                             ptypes types)))                             ptypes types)))
172            (if (and (not (find-if #'first res))            (if (and (not (find-if #'first res))
173                     (every #'type-check-template types))                     (every #'type-check-template types)
174                       (not force-hairy))
175                (values :simple types)                (values :simple types)
176                (values :hairy res))))))                (values :hairy res))))))
177    
# Line 188  Line 190 
190  ;;; In this :SIMPLE case, the second value is a list of the type restrictions  ;;; In this :SIMPLE case, the second value is a list of the type restrictions
191  ;;; specified for the leading positional values.  ;;; specified for the leading positional values.
192  ;;;  ;;;
193    ;;; We force a check to be hairy even when there are fixed values if we are in
194    ;;; a context where we may be forced to use the unknown values convention
195    ;;; anyway.  This is because IR2tran can't generate type checks for unknown
196    ;;; values continuations but people could still be depending on the check being
197    ;;; done.  We only care about EXIT and RETURN (not MV-COMBINATION) since these
198    ;;; are the only contexts where the ultimate values receiver
199    ;;;
200  ;;; In the :HAIRY case, the second value is a list of triples of the form:  ;;; In the :HAIRY case, the second value is a list of triples of the form:
201  ;;;    (Not-P Type Original-Type)  ;;;    (Not-P Type Original-Type)
202  ;;;  ;;;
# Line 209  Line 218 
218      (multiple-value-bind (types count)      (multiple-value-bind (types count)
219                           (no-function-values-types type)                           (no-function-values-types type)
220        (cond ((not (eq count :unknown))        (cond ((not (eq count :unknown))
221               (maybe-negate-check cont types))               (if (or (exit-p dest)
222                         (and (return-p dest)
223                              (multiple-value-bind
224                                  (ignore count)
225                                  (values-types (return-result-type dest))
226                                (declare (ignore ignore))
227                                (eq count :unknown))))
228                     (maybe-negate-check cont types t)
229                     (maybe-negate-check cont types nil)))
230              ((and (mv-combination-p dest)              ((and (mv-combination-p dest)
231                    (eq (basic-combination-kind dest) :local))                    (eq (basic-combination-kind dest) :local))
232               (assert (values-type-p type))               (assert (values-type-p type))
233               (maybe-negate-check cont (args-type-optional type)))               (maybe-negate-check cont (args-type-optional type) nil))
234              (t              (t
235               (values :too-hairy nil))))))               (values :too-hairy nil))))))
236    
# Line 235  Line 252 
252  ;;; since if we pass up this chance to do the check, it will be too late.  The  ;;; since if we pass up this chance to do the check, it will be too late.  The
253  ;;; penalty for being too conservative is duplicated type checks.  ;;; penalty for being too conservative is duplicated type checks.
254  ;;;  ;;;
255  ;;; We always return true if there is a compile-time type error on the  ;;; If there is a compile-time type error, then we always return true unless
256  ;;; continuation, so that this error will be signalled at runtime as well.  ;;; the DEST is a full call.  With a full call, the theory is that the type
257    ;;; error is probably from a declaration in (or on) the callee, so the callee
258    ;;; should be able to do the check.  We want to let the callee do the check,
259    ;;; because it is possible that the error is really in the callee, not the
260    ;;; caller.  We don't want to make people recompile all calls to a function
261    ;;; when they were originally compiled with a bad declaration (or an old type
262    ;;; assertion derived from a definition appearing after the call.)
263  ;;;  ;;;
264  (defun probable-type-check-p (cont)  (defun probable-type-check-p (cont)
265    (declare (type continuation cont))    (declare (type continuation cont))
266    (let ((dest (continuation-dest cont)))    (let ((dest (continuation-dest cont)))
267      (cond ((eq (continuation-type-check cont) :error))      (cond ((eq (continuation-type-check cont) :error)
268               (if (and (combination-p dest) (eq (combination-kind dest) :full))
269                   nil
270                   t))
271            ((or (not dest)            ((or (not dest)
272                 (policy dest (zerop safety)))                 (policy dest (zerop safety)))
273             nil)             nil)
# Line 370  Line 396 
396    (undefined-value))    (undefined-value))
397    
398    
399    ;;; DO-TYPE-WARNING  --  Internal
400    ;;;
401    ;;;    Emit a type warning for Node.  If the value of node is being used for a
402    ;;; variable binding, we figure out which one for source context.  If the value
403    ;;; is a constant, we print it specially.  We also print forms known to be of
404    ;;; type NIL specially.
405    ;;;
406    (defun do-type-warning (node)
407      (declare (type node node))
408      (let* ((*compiler-error-context* node)
409             (cont (node-cont node))
410             (atype-spec (type-specifier (continuation-asserted-type cont)))
411             (dtype (node-derived-type node))
412             (dest (continuation-dest cont))
413             (what (when (and (combination-p dest)
414                              (eq (combination-kind dest) :local))
415                     (let ((lambda (combination-lambda dest))
416                           (pos (position cont (combination-args dest))))
417                       (format nil "~:[A possible~;The~] binding of ~S"
418                               (and (continuation-use cont)
419                                    (eq (functional-kind lambda) :let))
420                               (leaf-name (elt (lambda-vars lambda) pos)))))))
421        (cond ((and (ref-p node) (constant-p (ref-leaf node)))
422               (compiler-warning "~:[This~;~:*~A~] is not a ~S:~%  ~S"
423                                 what atype-spec (constant-value (ref-leaf node))))
424               ((eq dtype *empty-type*)
425                (if what
426                    (compiler-warning "~A is an expression that does not return."
427                                      what)
428                    (compiler-warning "Expression that does not return when ~
429                                       expecting a value of type:~%  ~S."
430                                      atype-spec)))
431               (t
432                (compiler-warning "~:[Result~;~:*~A~] is a ~S, ~<~%~:;not a ~S.~>"
433                                  what (type-specifier dtype) atype-spec))))
434      (undefined-value))
435    
436    
437    ;;; MARK-ERROR-CONTINUATION  --  Internal
438    ;;;
439    ;;;    Mark Cont as being a continuation with a manifest type error.  We set
440    ;;; the kind to :ERROR, and clear any FUNCTION-INFO if the continuation is an
441    ;;; argument to a known call.  The last is done so that the back end doesn't
442    ;;; have to worry about type errors in arguments to known functions.  This
443    ;;; clearing is inhibited for things with IR2-CONVERT methods, since we can't
444    ;;; do a full call to funny functions.
445    ;;;
446    (defun mark-error-continuation (cont)
447      (declare (type continuation cont))
448      (setf (continuation-%type-check cont) :error)
449      (let ((dest (continuation-dest cont)))
450        (when (and (combination-p dest)
451                   (let ((info (basic-combination-kind dest)))
452                     (and (function-info-p info)
453                          (not (function-info-ir2-convert info)))))
454          (setf (basic-combination-kind dest) :full)))
455      (undefined-value))
456    
457    
458  ;;; Generate-Type-Checks  --  Interface  ;;; Generate-Type-Checks  --  Interface
459  ;;;  ;;;
460  ;;;    Loop over all blocks in Component that have TYPE-CHECK set, looking for  ;;;    Loop over all blocks in Component that have TYPE-CHECK set, looking for
# Line 377  Line 462 
462  ;;; compile-time type errors and determine if and how to do run-time type  ;;; compile-time type errors and determine if and how to do run-time type
463  ;;; checks.  ;;; checks.
464  ;;;  ;;;
465  ;;;    If there is a compile-time type error, then we mark the continuation  ;;;    If there is a compile-time type error, then we mark the continuation and
466  ;;; with a :ERROR kind, emit a warning if appropriate, and clear any  ;;; emit a warning if appropriate.  This part loops over all the uses of the
467  ;;; FUNCTION-INFO if the continuation is an argument to a known call.  The last  ;;; continuation, since after we convert the check, the :DELETED kind will
468  ;;; is done so that the back end doesn't have to worry about type errors in  ;;; inhibit warnings about the types of other uses.
 ;;; arguments to known functions.  
469  ;;;  ;;;
470  ;;;    If a continuation is too complex to be checked by the back end, or is  ;;;    If a continuation is too complex to be checked by the back end, or is
471  ;;; better checked with explicit code, then convert to an explicit test.  ;;; better checked with explicit code, then convert to an explicit test.
# Line 400  Line 484 
484      (when (block-type-check block)      (when (block-type-check block)
485        (do-nodes (node cont block)        (do-nodes (node cont block)
486          (let ((type-check (continuation-type-check cont)))          (let ((type-check (continuation-type-check cont)))
487            (unless (member type-check '(nil :error))            (unless (member type-check '(nil :error :deleted))
488              (let ((dtype (node-derived-type node))              (let ((atype (continuation-asserted-type cont)))
489                    (atype (continuation-asserted-type cont)))                (do-uses (use cont)
490                (unless (values-types-intersect dtype atype)                  (unless (values-types-intersect (node-derived-type use)
491                  (setf (continuation-%type-check cont) :error)                                                  atype)
492                  (let ((dest (continuation-dest cont)))                    (mark-error-continuation cont)
493                    (when (and (combination-p dest)                    (unless (policy node (= brevity 3))
494                               (function-info-p (basic-combination-kind dest)))                      (do-type-warning use))))))
495                      (setf (basic-combination-kind dest) :full)))  
                 (unless (policy node (= brevity 3))  
                   (let ((*compiler-error-context* node))  
                     (if (and (ref-p node) (constant-p (ref-leaf node)))  
                         (compiler-warning "This is not a ~S:~%  ~S"  
                                           (type-specifier atype)  
                                           (constant-value (ref-leaf node)))  
                         (compiler-warning "Result is a ~S, not a ~S."  
                                           (type-specifier dtype)  
                                           (type-specifier atype))))))))  
   
496            (when (eq type-check t)            (when (eq type-check t)
497              (let ((check-p (probable-type-check-p cont)))              (let ((check-p (probable-type-check-p cont)))
498                (multiple-value-bind (check types)                (multiple-value-bind (check types)

Legend:
Removed from v.1.12  
changed lines
  Added in v.1.13

  ViewVC Help
Powered by ViewVC 1.1.5