From dfb1d6b0fb2f8cd3aba382dbd38105488be8d001 Mon Sep 17 00:00:00 2001
From: ram <ram>
Date: Fri, 28 Dec 1990 16:49:09 +0000
Subject: [PATCH] Changed MAYBE-NEGATE-CHECK to allow weakened checks to be
 simple when debug-info is not important, so that we can use CHECK-STRUCTURE,
 etc. Changed TYPE-TEST-COST to penalize predicates as opposed to check
 templates so that we will use a check template in favor of a "same cost"
 predicate.

---
 compiler/checkgen.lisp | 26 ++++++++++++++++++--------
 1 file changed, 18 insertions(+), 8 deletions(-)

diff --git a/compiler/checkgen.lisp b/compiler/checkgen.lisp
index fca90aec8..b006629fa 100644
--- a/compiler/checkgen.lisp
+++ b/compiler/checkgen.lisp
@@ -59,7 +59,7 @@
 	    (template-cost check)
 	    (let ((found (cdr (assoc type *type-predicates* :test #'type=))))
 	      (if found
-		  (function-cost found)
+		  (+ (function-cost found) (function-cost 'eq))
 		  nil))))
       (typecase type
 	(union-type
@@ -145,8 +145,11 @@
 ;;; impossible, we do a hairy test with non-negated types.  If true,
 ;;; Force-Hairy forces a hairy type check.
 ;;;
-;;;    When doing a non-negated hairy check, we call MAYBE-WEAKEN-CHECK to
-;;; weaken the test to a convenient supertype (conditional on policy.)
+;;;    When doing a non-negated check, we call MAYBE-WEAKEN-CHECK to weaken the
+;;; test to a convenient supertype (conditional on policy.)  If debug-info is
+;;; not particularly important (debug <= 1) or speed is 3, then we allow
+;;; weakened checks to be simple, resulting in less informative error messages,
+;;; but saving space and possibly time.
 ;;;
 (defun maybe-negate-check (cont types force-hairy)
   (declare (type continuation cont) (list types))
@@ -169,11 +172,18 @@
 				     (list t diff c)
 				     (list nil weak c))))
 			   ptypes types)))
-	  (if (and (not (find-if #'first res))
-		   (every #'type-check-template types)
-		   (not force-hairy))
-	      (values :simple types)
-	      (values :hairy res))))))
+	  (cond ((or force-hairy (find-if #'first res))
+		 (values :hairy res))
+		((every #'type-check-template types)
+		 (values :simple types))
+		((policy (continuation-dest cont)
+			 (or (<= debug 1) (and (= speed 3) (/= debug 3))))
+		 (let ((weakened (mapcar #'second res)))
+		   (if (every #'type-check-template weakened)
+		       (values :simple weakened)
+		       (values :hairy res))))
+		(t
+		 (values :hairy res)))))))
 	    
 
 ;;; CONTINUATION-CHECK-TYPES  --  Interface
-- 
GitLab