X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fcheckgen.lisp;h=237906afbd7099bf947be992ef4116fef7452595;hb=104ee7ee303efa16e415f5e75df635ac54dba733;hp=89a6cc4d46d17145c235b120b4e7aa6968edd32e;hpb=cfb9e3640e34706acdfccd26236024de259f3b4f;p=sbcl.git

diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp
index 89a6cc4..237906a 100644
--- a/src/compiler/checkgen.lisp
+++ b/src/compiler/checkgen.lisp
@@ -24,12 +24,12 @@
 ;;;
 ;;; We special-case NULL, since it does have a source tranform and is
 ;;; interesting to us.
-(defun function-cost (name)
+(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 (function-info-templates info)))
+	(let ((templates (fun-info-templates info)))
 	  (if templates
 	      (template-cost (first templates))
 	      (case name
@@ -49,32 +49,29 @@
 	    (let ((found (cdr (assoc type *backend-type-predicates*
 				     :test #'type=))))
 	      (if found
-		  (+ (function-cost found) (function-cost 'eq))
+		  (+ (fun-guessed-cost found) (fun-guessed-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)))
+	    (fun-guessed-cost 'eq)))
 	(numeric-type
 	 (* (if (numeric-type-complexp type) 2 1)
-	    (function-cost
+	    (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))
-	    (function-cost 'car)
+	    (fun-guessed-cost 'car)
 	    (type-test-cost (cons-type-car-type type))
-	    (function-cost 'cdr)
+	    (fun-guessed-cost 'cdr)
 	    (type-test-cost (cons-type-cdr-type type))))
 	(t
-	 (function-cost 'typep)))))
+	 (fun-guessed-cost 'typep)))))
 
 ;;;; checking strategy determination
 
@@ -112,14 +109,15 @@
 	       min-type
 	       *universal-type*)))))
 
-;;; Like VALUES-TYPES, only mash any complex function types to FUNCTION.
-(defun no-function-values-types (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 (function-type-p type)
-			    (specifier-type 'function)
-			    type))
+    (values (mapcar (lambda (type)
+		      (if (fun-type-p type)
+			  (specifier-type 'function)
+			  type))
 		    res)
 	    count)))
 
@@ -133,7 +131,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.)
@@ -148,23 +146,23 @@
 (defun maybe-negate-check (cont types force-hairy)
   (declare (type continuation cont) (list types))
   (multiple-value-bind (ptypes count)
-      (no-function-values-types (continuation-proven-type cont))
+      (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 (maybe-weaken-check x cont) x))
+		    (mapcar (lambda (x)
+			      (list nil (maybe-weaken-check x cont) x))
 			    types)))
-	(let ((res (mapcar #'(lambda (p c)
-			       (let ((diff (type-difference p c))
-				     (weak (maybe-weaken-check c cont)))
-				 (if (and diff
-					  (< (type-test-cost diff)
-					     (type-test-cost weak))
-					  *complement-type-checks*)
-				     (list t diff c)
-				     (list nil weak c))))
+	(let ((res (mapcar (lambda (p c)
+			     (let ((diff (type-difference p c))
+				   (weak (maybe-weaken-check c cont)))
+			       (if (and diff
+					(< (type-test-cost diff)
+					   (type-test-cost weak))
+					*complement-type-checks*)
+				   (list t diff c)
+				   (list nil weak c))))
 			   ptypes types)))
 	  (cond ((or force-hairy (find-if #'first res))
 		 (values :hairy res))
@@ -217,8 +215,8 @@
   (declare (type continuation cont))
   (let ((type (continuation-asserted-type cont))
 	(dest (continuation-dest cont)))
-    (assert (not (eq type *wild-type*)))
-    (multiple-value-bind (types count) (no-function-values-types type)
+    (aver (not (eq type *wild-type*)))
+    (multiple-value-bind (types count) (no-fun-values-types type)
       (cond ((not (eq count :unknown))
 	     (if (or (exit-p dest)
 		     (and (return-p dest)
@@ -230,7 +228,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))))))
@@ -266,7 +264,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)
@@ -277,12 +276,12 @@
 	     (cond ((eq cont (basic-combination-fun dest)) t)
 		   ((eq kind :local) t)
 		   ((member kind '(:full :error)) nil)
-		   ((function-info-ir2-convert kind) t)
+		   ((fun-info-ir2-convert kind) t)
 		   (t
-		    (dolist (template (function-info-templates kind) nil)
+		    (dolist (template (fun-info-templates kind) nil)
 		      (when (eq (template-ltn-policy template) :fast-safe)
 			(multiple-value-bind (val win)
-			    (valid-function-use dest (template-type template))
+			    (valid-fun-use dest (template-type template))
 			  (when (or val (not win)) (return t)))))))))
 	  (t t))))
 
@@ -302,15 +301,15 @@
 (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-function-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))))))
+       ,@(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))))
@@ -321,7 +320,7 @@
 ;;; passes them on to CONT.
 (defun convert-type-check (cont types)
   (declare (type continuation cont) (type list types))
-  (with-ir1-environment (continuation-dest cont)
+  (with-ir1-environment-from-node (continuation-dest cont)
 
     ;; Ensuring that CONT starts a block lets us freely manipulate its uses.
     (ensure-block-start cont)
@@ -356,13 +355,13 @@
 	(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
 	;;   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.
+	;;   default from WITH-BELATED-IR1-ENVIRONMENT.
 	;; 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
@@ -388,7 +387,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)))
@@ -396,7 +395,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))
 
@@ -405,7 +404,7 @@
 ;;; 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 do-type-warning (node)
+(defun emit-type-warning (node)
   (declare (type node node))
   (let* ((*compiler-error-context* node)
 	 (cont (node-cont node))
@@ -419,19 +418,20 @@
 		   (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"
-			     what atype-spec (constant-value (ref-leaf node))))
+	   (compiler-warn "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~%  ~S"
+			  what atype-spec (constant-value (ref-leaf node))))
 	  (t
-	   (compiler-warning
+	   (compiler-warn
 	    "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
 	    what (type-specifier dtype) atype-spec))))
   (values))
 
 ;;; Mark CONT as being a continuation with a manifest type error. We
-;;; set the kind to :ERROR, and clear any FUNCTION-INFO if the
+;;; set the kind to :ERROR, and clear any FUN-INFO if the
 ;;; continuation is an argument to a known call. The last is done so
 ;;; that the back end doesn't have to worry about type errors in
 ;;; arguments to known functions. This clearing is inhibited for
@@ -444,12 +444,12 @@
     (when (and (combination-p dest)
 	       (let ((kind (basic-combination-kind dest)))
 		 (or (eq kind :full)
-		     (and (function-info-p kind)
-			  (not (function-info-ir2-convert kind))))))
+		     (and (fun-info-p kind)
+			  (not (fun-info-ir2-convert kind))))))
       (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.
@@ -487,13 +487,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 (= inhibit-warnings 3))
-		      (do-type-warning use))))))
-	    (when (and (eq type-check t)
-		       (not *byte-compiling*))
+		      (emit-type-warning use))))))
+	    (when (eq type-check t)
 	      (cond ((probable-type-check-p cont)
 		     (conts cont))
 		    (t