X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fcheckgen.lisp;h=2d983771f98be9333d5df442d66e67eee3e8ee80;hb=0cfad881b88e03971a2b3ef0c0c0fc2e5f4f1bc8;hp=2a91eda8c9b1180ff47b97c6dc69467a12381669;hpb=77360ee4a1f94c41b807be7ad0e8687199fceef1;p=sbcl.git diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 2a91eda..2d98377 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -52,11 +52,8 @@ (+ (function-cost found) (function-cost 'eq)) nil)))) (typecase type - (union-type - (collect ((res 0 +)) - (dolist (mem (union-type-types type)) - (res (type-test-cost mem))) - (res))) + (compound-type + (reduce #'+ (compound-type-types type) :key 'type-test-cost)) (member-type (* (length (member-type-members type)) (function-cost 'eq))) @@ -90,7 +87,9 @@ (defun maybe-weaken-check (type cont) (declare (type ctype type) (type continuation cont)) (cond ((policy (continuation-dest cont) - (<= speed safety) (<= space safety) (<= cspeed safety)) + (and (<= speed safety) + (<= space safety) + (<= compilation-speed safety))) type) (t (let ((min-cost (type-test-cost type)) @@ -115,7 +114,7 @@ (declare (type ctype type)) (multiple-value-bind (res count) (values-types type) (values (mapcar #'(lambda (type) - (if (function-type-p type) + (if (fun-type-p type) (specifier-type 'function) type)) res) @@ -131,7 +130,7 @@ ;;; 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. +;;; 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.) @@ -215,7 +214,7 @@ (declare (type continuation cont)) (let ((type (continuation-asserted-type cont)) (dest (continuation-dest cont))) - (assert (not (eq type *wild-type*))) + (aver (not (eq type *wild-type*))) (multiple-value-bind (types count) (no-function-values-types type) (cond ((not (eq count :unknown)) (if (or (exit-p dest) @@ -228,7 +227,7 @@ (maybe-negate-check cont types nil))) ((and (mv-combination-p dest) (eq (basic-combination-kind dest) :local)) - (assert (values-type-p type)) + (aver (values-type-p type)) (maybe-negate-check cont (args-type-optional type) nil)) (t (values :too-hairy nil)))))) @@ -247,7 +246,9 @@ ;;; 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. +;;; 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. ;;; ;;; If there is a compile-time type error, then we always return true ;;; unless the DEST is a full call. With a full call, the theory is @@ -262,7 +263,8 @@ (declare (type continuation cont)) (let ((dest (continuation-dest cont))) (cond ((eq (continuation-type-check cont) :error) - (if (and (combination-p dest) (eq (combination-kind dest) :error)) + (if (and (combination-p dest) + (eq (combination-kind dest) :error)) nil t)) ((or (not dest) @@ -276,7 +278,7 @@ ((function-info-ir2-convert kind) t) (t (dolist (template (function-info-templates kind) nil) - (when (eq (template-policy template) :fast-safe) + (when (eq (template-ltn-policy template) :fast-safe) (multiple-value-bind (val win) (valid-function-use dest (template-type template)) (when (or val (not win)) (return t))))))))) @@ -300,7 +302,7 @@ `(multiple-value-bind ,temps 'dummy ,@(mapcar #'(lambda (temp type) (let* ((spec - (let ((*unparse-function-type-simplify* t)) + (let ((*unparse-fun-type-simplify* t)) (type-specifier (second type)))) (test (if (first type) `(not ,spec) spec))) `(unless (typep ,temp ',test) @@ -352,7 +354,7 @@ (ir1-convert new-start dummy (make-type-check-form types)) ;; TO DO: Why should this be true? -- WHN 19990601 - (assert (eq (continuation-block dummy) new-block)) + (aver (eq (continuation-block dummy) new-block)) ;; KLUDGE: Comments at the head of this function in CMU CL ;; said that somewhere in here we @@ -384,7 +386,7 @@ (let* ((node (continuation-use cont)) (args (basic-combination-args node)) (victim (first args))) - (assert (and (= (length args) 1) + (aver (and (= (length args) 1) (eq (constant-value (ref-leaf (continuation-use victim))) @@ -392,7 +394,7 @@ (substitute-continuation new-start victim))) ;; Invoking local call analysis converts this call to a LET. - (local-call-analyze *current-component*)) + (locall-analyze-component *current-component*)) (values)) @@ -415,7 +417,8 @@ (format nil "~:[A possible~;The~] binding of ~S" (and (continuation-use cont) (eq (functional-kind lambda) :let)) - (leaf-name (elt (lambda-vars lambda) pos))))))) + (leaf-source-name (elt (lambda-vars lambda) + pos))))))) (cond ((eq dtype *empty-type*)) ((and (ref-p node) (constant-p (ref-leaf node))) (compiler-warning "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S" @@ -445,7 +448,7 @@ (setf (basic-combination-kind dest) :error))) (values)) -;;; Loop over all blocks in Component that have TYPE-CHECK set, +;;; 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. @@ -483,13 +486,12 @@ (unless (member type-check '(nil :error :deleted)) (let ((atype (continuation-asserted-type cont))) (do-uses (use cont) - (unless (values-types-intersect (node-derived-type use) - atype) + (unless (values-types-equal-or-intersect + (node-derived-type use) atype) (mark-error-continuation cont) - (unless (policy node (= brevity 3)) + (unless (policy node (= inhibit-warnings 3)) (do-type-warning use)))))) - (when (and (eq type-check t) - (not *byte-compiling*)) + (when (eq type-check t) (cond ((probable-type-check-p cont) (conts cont)) (t @@ -504,7 +506,7 @@ (:too-hairy (let* ((context (continuation-dest cont)) (*compiler-error-context* context)) - (when (policy context (>= safety brevity)) + (when (policy context (>= safety inhibit-warnings)) (compiler-note "type assertion too complex to check:~% ~S." (type-specifier (continuation-asserted-type cont)))))