From 7ce2c42adf3d62f03086de940adaee48e6161a40 Mon Sep 17 00:00:00 2001
From: Alexey Dejneka <adejneka@comail.ru>
Date: Mon, 11 Nov 2002 08:37:00 +0000
Subject: [PATCH] 0.7.9.41:         * Weaken type checks immediately when they
 are set according           to the corresponding policy.   
      * Because this change significantly increases load on
 the type           algebra system, add caches to the
 latter.         * Fix bug in
 %CONTINUATION-%EXTERNALLY-CHECKABLE-TYPE: an          
 argument of a combination might be omitted.

---
 BUGS                              |   34 ++++--
 package-data-list.lisp-expr       |    2 +
 src/code/early-extensions.lisp    |   27 +++++
 src/code/early-type.lisp          |    7 +-
 src/code/late-type.lisp           |   23 +++-
 src/compiler/array-tran.lisp      |   20 +--
 src/compiler/checkgen.lisp        |  242 +++++++++++++++++++++----------------
 src/compiler/ctype.lisp           |    5 +-
 src/compiler/ir1-translators.lisp |   33 +++--
 src/compiler/ir1opt.lisp          |   70 ++++++-----
 src/compiler/ir1tran.lisp         |   20 ++-
 src/compiler/ir1util.lisp         |    7 +-
 src/compiler/ir2tran.lisp         |    4 +-
 src/compiler/lexenv.lisp          |    5 +-
 src/compiler/locall.lisp          |   11 +-
 src/compiler/node.lisp            |    2 +
 tests/compiler.impure.lisp        |   36 ++++++
 version.lisp-expr                 |    2 +-
 18 files changed, 365 insertions(+), 185 deletions(-)

diff --git a/BUGS b/BUGS
index e1e6c12..59f201f 100644
--- a/BUGS
+++ b/BUGS
@@ -1014,11 +1014,11 @@ WORKAROUND:
        returns (1 2 3) instead of signalling an error. This was fixed by 
        APD's "more strict type checking patch", but although the fixed
        code (in sbcl-0.7.7.19) works (signals TYPE-ERROR) interactively,
-       it's difficult to write a regression test for it, because 
+       it's difficult to write a regression test for it, because
        (IGNORE-ERRORS (MULTIPLE-VALUE-PROG1 (PROGN (THE REAL '(1 2 3)))))
        still returns (1 2 3).
-  still-broken parts:  
-    b. (IGNORE-ERRORS (MULTIPLE-VALUE-PROG1 (PROGN (THE REAL '(1 2 3)))))    
+  still-broken parts:
+    b. (IGNORE-ERRORS (MULTIPLE-VALUE-PROG1 (PROGN (THE REAL '(1 2 3)))))
        returns (1 2 3). (As above, this shows up when writing regression
        tests for fixed-ness of part a.)
     c. Also in sbcl-0.7.7.9, (IGNORE-ERRORS (THE REAL '(1 2 3))) => (1 2 3).
@@ -1118,7 +1118,7 @@ WORKAROUND:
   29-bit pseudorandom numbers?
 
 208: "package confusion in PCL handling of structure slot handlers"
-  In sbcl-0.7.8 compiling and loading 
+  In sbcl-0.7.8 compiling and loading
 	(in-package :cl)
 	(defstruct foo (slot (error "missing")) :type list :read-only t)
 	(defmethod print-object ((foo foo) stream) (print nil stream))
@@ -1138,7 +1138,7 @@ WORKAROUND:
 
        ; in: LAMBDA NIL
        ;     (FOO :Y 1 :Y 2)
-       ; 
+       ;
        ; caught STYLE-WARNING:
        ;   The variable #:G15 is defined but never used.
 
@@ -1148,14 +1148,14 @@ WORKAROUND:
   given an error instead (ANSI 17.1.1 allows this behaviour on the part
   of the implementation, as conforming code cannot give non-proper
   sequences to these functions.  MAP also has this problem (and
-  solution), though arguably the convenience of being able to do 
-    (MAP 'LIST '+ FOO '#1=(1 . #1#)) 
+  solution), though arguably the convenience of being able to do
+    (MAP 'LIST '+ FOO '#1=(1 . #1#))
   might be classed as more important (though signalling an error when
   all of the arguments are circular is probably desireable).
 
 213: "Sequence functions and type checking"
   a. MAKE-SEQUENCE, COERCE, MERGE and CONCATENATE cannot deal with
-     various complicated, though recognizeable, CONS types [e.g. 
+     various complicated, though recognizeable, CONS types [e.g.
        (CONS * (CONS * NULL))
      which according to ANSI should be recognized] (and, in SAFETY 3
      code, should return a list of LENGTH 2 or signal an error)
@@ -1168,7 +1168,7 @@ WORKAROUND:
        (CONS INTEGER *)
      whether or not the return value is of this type.  This is
      probably permitted by ANSI (see "Exceptional Situations" under
-     ANSI MAKE-SEQUENCE), but the DERIVE-TYPE mechanism does not 
+     ANSI MAKE-SEQUENCE), but the DERIVE-TYPE mechanism does not
      know about this escape clause, so code of the form
        (INTEGERP (CAR (MAKE-SEQUENCE '(CONS INTEGER *) 2)))
      can erroneously return T.
@@ -1246,7 +1246,7 @@ WORKAROUND:
 219: "DEFINE-COMPILER-MACRO in non-toplevel contexts evaluated at compile-time"
   In sbcl-0.7.9:
 
-  * (defun foo (x) 
+  * (defun foo (x)
       (when x
         (define-compiler-macro bar (&whole whole)
           (declare (ignore whole))
@@ -1260,7 +1260,7 @@ WORKAROUND:
   * (baz t)
   1
 
-220: 
+220:
   Sbcl 0.7.9 fails to compile
 
   (multiple-value-call #'list
@@ -1310,9 +1310,19 @@ WORKAROUND:
     	  (apply bar0 rest)
     	  (format t "~&back from BAR~%"))))
     (bar 12)
-  recurses endlessly in sbcl-0.7.9.32. (Or it works if #' and 
+  recurses endlessly in sbcl-0.7.9.32. (Or it works if #' and
   FDEFINITION are replaced by SYMBOL-FUNCTION.)
 
+224:
+  SBCL 0.7.8 fails to compile
+
+  (localy (declare (optimize (safety 3)))
+          (ignore-errors (progn (values-list (car (list '(1 . 2)))) t)))
+
+225:
+  As reported by Gilbert Baumann on free-clim mailing list 2002-11-11,
+  there is no class STRING-STREAM.
+
 DEFUNCT CATEGORIES OF BUGS
   IR1-#:
     These labels were used for bugs related to the old IR1 interpreter.
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 2882ecc..8da64b8 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -748,6 +748,7 @@ retained, possibly temporariliy, because it might be used internally."
              "DEFENUM"
              "DEFPRINTER"
              "AVER" "ENFORCE-TYPE"
+             "AWHEN" "ACOND" "IT"
 
 	     ;; ..and CONDITIONs..
 	     "BUG"
@@ -793,6 +794,7 @@ retained, possibly temporariliy, because it might be used internally."
              ;; hash caches
              "DEFINE-HASH-CACHE"
              "DEFUN-CACHED"
+             "DEFINE-CACHED-SYNONYM"
 
              ;; time
              "FORMAT-DECODED-TIME"
diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index e4fa9c5..a23f10f 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -560,6 +560,19 @@
 			     ,@(values-names))
 			    (values ,@(values-names)))
 			  (values ,@(values-names))))))))))))
+
+(defmacro define-cached-synonym
+    (name &optional (original (symbolicate "%" name)))
+  (let ((cached-name (symbolicate "%%" name "-cached")))
+    `(progn
+       (defun-cached (,cached-name :hash-bits 8
+                                   :hash-function (lambda (x)
+                                                    (logand (sxhash x) #xff)))
+           ((args equal))
+         (apply #',original args))
+       (defun ,name (&rest args)
+         (,cached-name args)))))
+
 
 ;;;; package idioms
 
@@ -1015,3 +1028,17 @@ which can be found at <http://sbcl.sourceforge.net/>.~:@>"
   (warn "using deprecated ~S~@[, should use ~S instead~]"
 	bad-name
 	good-name))
+
+;;; Anaphoric macros
+(defmacro awhen (test &body body)
+  `(let ((it ,test))
+     (when it ,@body)))
+
+(defmacro acond (&rest clauses)
+  (if (null clauses)
+      `()
+      (destructuring-bind ((test &body body) &rest rest) clauses
+        (once-only ((test test))
+          `(if ,test
+               (let ((it ,test)) (declare (ignorable it)),@body)
+               (acond ,@rest))))))
diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index 8dcb9c7..e4df2ee 100644
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -58,7 +58,9 @@
 (defstruct (values-type
 	    (:include args-type
 		      (class-info (type-class-or-lose 'values)))
+            (:constructor %make-values-type)
 	    (:copier nil)))
+(define-cached-synonym make-values-type)
 
 (!define-type-class values)
 
@@ -207,6 +209,7 @@
 ;;; things such as SIMPLE-STRING.
 (defstruct (array-type (:include ctype
 				 (class-info (type-class-or-lose 'array)))
+                       (:constructor %make-array-type)
 		       (:copier nil))
   ;; the dimensions of the array, or * if unspecified. If a dimension
   ;; is unspecified, it is *.
@@ -217,6 +220,7 @@
   (element-type (missing-arg) :type ctype)
   ;; the element type as it is specialized in this implementation
   (specialized-element-type *wild-type* :type ctype))
+(define-cached-synonym make-array-type)
 
 ;;; A MEMBER-TYPE represent a use of the MEMBER type specifier. We
 ;;; bother with this at this level because MEMBER types are fairly
@@ -248,6 +252,7 @@
 				 (class-info (type-class-or-lose 'union)))
 		       (:constructor %make-union-type (enumerable types))
 		       (:copier nil)))
+(define-cached-synonym make-union-type)
 
 ;;; An INTERSECTION-TYPE represents a use of the AND type specifier
 ;;; which we couldn't canonicalize to something simpler. Canonical form:
@@ -309,7 +314,7 @@
                                 (logand (sxhash x) #x3FF))
 	       :hash-bits 10
 	       :init-wrapper !cold-init-forms)
-	      ((orig eq))
+	      ((orig equal))
   (let ((u (uncross orig)))
     (or (info :type :builtin u)
 	(let ((spec (type-expand u)))
diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index f867fc9..3cd0808 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -353,7 +353,7 @@
     res))
 
 (!def-type-translator values (&rest values)
-  (let ((res (make-values-type)))
+  (let ((res (%make-values-type)))
     (parse-args-types values res)
     res))
 
@@ -479,6 +479,8 @@
 (defun args-type-op (type1 type2 operation nreq default-type)
   (declare (type ctype type1 type2 default-type)
  	   (type function operation nreq))
+  (when (eq type1 type2)
+    (values type1 t))
   (if (or (values-type-p type1) (values-type-p type2))
       (let ((type1 (coerce-to-values type1))
 	    (type2 (coerce-to-values type2)))
@@ -914,6 +916,11 @@
 	nil)))
 
 (defun type-intersection (&rest input-types)
+  (%type-intersection input-types))
+(defun-cached (%type-intersection :hash-bits 8
+                                  :hash-function (lambda (x)
+                                                   (logand (sxhash x) #xff)))
+    ((input-types equal))
   (let ((simplified-types (simplified-compound-types input-types
 						     #'intersection-type-p
 						     #'type-intersection2)))
@@ -946,10 +953,15 @@
 					 *universal-type*))))
 
 (defun type-union (&rest input-types)
+  (%type-union input-types))
+(defun-cached (%type-union :hash-bits 8
+                           :hash-function (lambda (x)
+                                            (logand (sxhash x) #xff)))
+    ((input-types equal))
   (let ((simplified-types (simplified-compound-types input-types
 						     #'union-type-p
 						     #'type-union2)))
-    (make-compound-type-or-something #'%make-union-type
+    (make-compound-type-or-something #'make-union-type
 				     simplified-types
 				     (every #'type-enumerable simplified-types)
 				     *empty-type*)))
@@ -2106,7 +2118,7 @@
 		 *empty-type*))))))
 
 (!define-type-method (member :complex-intersection2) (type1 type2)
-  (block punt		     
+  (block punt
     (collect ((members))
       (let ((mem2 (member-type-members type2)))
         (dolist (member mem2)
@@ -2496,14 +2508,15 @@
 				       (dimensions '*))
   (specialize-array-type
    (make-array-type :dimensions (canonical-array-dimensions dimensions)
+                    :complexp :maybe
 		    :element-type (specifier-type element-type))))
 
 (!def-type-translator simple-array (&optional (element-type '*)
 					      (dimensions '*))
   (specialize-array-type
    (make-array-type :dimensions (canonical-array-dimensions dimensions)
-		    :element-type (specifier-type element-type)
-		    :complexp nil)))
+                    :complexp nil
+		    :element-type (specifier-type element-type))))
 
 ;;;; utilities shared between cross-compiler and target system
 
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 2194cfa..7eabbc1 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -47,14 +47,18 @@
 (defun assert-new-value-type (new-value array)
   (let ((type (continuation-type array)))
     (when (array-type-p type)
-      (assert-continuation-type new-value
-				(array-type-specialized-element-type type))))
+      (assert-continuation-type
+       new-value
+       (array-type-specialized-element-type type)
+       (lexenv-policy (node-lexenv (continuation-dest new-value))))))
   (continuation-type new-value))
 
 (defun assert-array-complex (array)
-  (assert-continuation-type array
-			    (make-array-type :complexp t
-					     :element-type *wild-type*)))
+  (assert-continuation-type
+   array
+   (make-array-type :complexp t
+                    :element-type *wild-type*)
+   (lexenv-policy (node-lexenv (continuation-dest array)))))
 
 ;;; Return true if ARG is NIL, or is a constant-continuation whose
 ;;; value is NIL, false otherwise.
@@ -71,7 +75,8 @@
 (defun assert-array-rank (array rank)
   (assert-continuation-type
    array
-   (specifier-type `(array * ,(make-list rank :initial-element '*)))))
+   (specifier-type `(array * ,(make-list rank :initial-element '*)))
+   (lexenv-policy (node-lexenv (continuation-dest array)))))
 
 (defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
   (assert-array-rank array (length indices))
@@ -82,7 +87,8 @@
   ;; If the node continuation has a single use then assert its type.
   (let ((cont (node-cont node)))
     (when (= (length (find-uses cont)) 1)
-      (assert-continuation-type cont (extract-upgraded-element-type array))))
+      (assert-continuation-type cont (extract-upgraded-element-type array)
+                                (lexenv-policy (node-lexenv node)))))
   (extract-upgraded-element-type array))
 
 (defoptimizer (%aset derive-type) ((array &rest stuff))
diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp
index f824823..8b43ae3 100644
--- a/src/compiler/checkgen.lisp
+++ b/src/compiler/checkgen.lisp
@@ -72,6 +72,47 @@
 	    (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
 
@@ -80,34 +121,17 @@
 ;;; than safety, 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.
-;;;
-;;; 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.
-(defun maybe-weaken-check (type cont)
-  (declare (type ctype type) (type continuation cont))
-  (cond ((policy (continuation-dest cont)
+(defun maybe-weaken-check (type policy)
+  (declare (type ctype type))
+  (cond ((policy policy (zerop safety))
+         *wild-type*)
+        ((policy policy
 		 (and (<= speed safety)
 		      (<= space safety)
 		      (<= compilation-speed safety)))
 	 type)
 	(t
-	 (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))
-		     (setq found-super t
-			   min-type stype
-			   min-cost stype-cost))))))
-	   (if found-super
-	       min-type
-	       *universal-type*)))))
+	 (weaken-values-type type))))
 
 ;;; This is like VALUES-TYPES, only we mash any complex function types
 ;;; to FUNCTION.
@@ -143,39 +167,29 @@
 ;;; 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 force-hairy)
+(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 (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))))
-			   ptypes types)))
-	  (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)))))))
+        (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
@@ -211,27 +225,54 @@
 ;;; 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)
+(defun continuation-check-types (cont force-hairy)
   (declare (type continuation cont))
-  (let ((type (continuation-asserted-type cont))
+  (let ((ctype (continuation-type-to-check cont))
+        (atype (continuation-asserted-type cont))
 	(dest (continuation-dest cont)))
-    (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)
-			  (multiple-value-bind (ignore count)
-			      (values-types (return-result-type dest))
-			    (declare (ignore ignore))
-			    (eq count :unknown))))
-		 (maybe-negate-check cont types t)
-		 (maybe-negate-check cont types nil)))
-	    ((and (mv-combination-p dest)
-		  (eq (basic-combination-kind dest) :local))
-	     (aver (values-type-p type))
-	     (maybe-negate-check cont (args-type-optional type) nil))
-	    (t
-	     (values :too-hairy nil))))))
+    (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 ctype)
+        (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)
+                  (eq (combination-kind dest) :full)
+                  ;; 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
@@ -260,24 +301,11 @@
 	   (let ((kind (basic-combination-kind dest)))
 	     (cond ((eq cont (basic-combination-fun dest)) t)
 		   ((eq kind :local) t)
-                   ((mv-combination-p dest)
-                    ;; See bug 220
-                    nil)
-                   ((not (eq (continuation-asserted-type cont)
-                             (continuation-externally-checkable-type cont)))
-                    ;; There is an explicit assertion.
-                    t)
                    ((eq kind :full)
-                    ;; 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.)
-                    nil)
+                    (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
@@ -481,23 +509,27 @@
 		    (unless (policy node (= inhibit-warnings 3))
 		      (emit-type-warning use))))))
 	    (when (eq type-check t)
-	      (cond ((probable-type-check-p cont)
-		     (conts cont))
-		    (t
-		     (setf (continuation-%type-check cont) :no-check))))))
+	      (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))
-      (multiple-value-bind (check types) (continuation-check-types cont)
-	(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))))))
+      (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))
diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index 8ec2cfc..97923ac 100644
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -742,7 +742,8 @@
 	 ((not really-assert) t)
 	 (t
 	  (when atype
-	    (assert-continuation-type (return-result return) atype))
+	    (assert-continuation-type (return-result return) atype
+                                      (lexenv-policy (functional-lexenv functional))))
 	  (loop for var in vars and type in types do
 	    (cond ((basic-var-sets var)
 		   (when (and unwinnage-fun
@@ -770,7 +771,7 @@
                               :unwinnage-fun #'compiler-note
                               :where "proclamation"))))
 
-;;;;
+;;;; FIXME: Move to some other file.
 (defun check-catch-tag-type (tag)
   (declare (type continuation tag))
   (let ((ctype (continuation-type tag)))
diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index ccb901f..e14ed30 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -507,7 +507,8 @@
 (def-ir1-translator %funcall ((function &rest args) start cont)
   (let ((fun-cont (make-continuation)))
     (ir1-convert start fun-cont function)
-    (assert-continuation-type fun-cont (specifier-type 'function))
+    (assert-continuation-type fun-cont (specifier-type 'function)
+                              (lexenv-policy *lexenv*))
     (ir1-convert-combination-args fun-cont cont args)))
 
 ;;; This source transform exists to reduce the amount of work for the
@@ -747,13 +748,18 @@
 ;;; many branches there are going to be.
 (defun ir1ize-the-or-values (type cont lexenv place)
   (declare (type continuation cont) (type lexenv lexenv))
-  (let* ((ctype (if (typep type 'ctype) type (compiler-values-specifier-type type)))
-	 (old-type (or (lexenv-find cont type-restrictions)
-		       *wild-type*))
-	 (intersects (values-types-equal-or-intersect old-type ctype))
-	 (new (values-type-intersection old-type ctype)))
+  (let* ((atype (if (typep type 'ctype) type (compiler-values-specifier-type type)))
+	 (old-atype (or (lexenv-find cont type-restrictions)
+                        *wild-type*))
+         (old-ctype (or (lexenv-find cont weakend-type-restrictions)
+                        *wild-type*))
+	 (intersects (values-types-equal-or-intersect old-atype atype))
+	 (new-atype (values-type-intersection old-atype atype))
+         (new-ctype (values-type-intersection
+                     old-ctype (maybe-weaken-check atype (lexenv-policy lexenv)))))
     (when (null (find-uses cont))
-      (setf (continuation-asserted-type cont) new))
+      (setf (continuation-asserted-type cont) new-atype)
+      (setf (continuation-type-to-check cont) new-ctype))
     (when (and (not intersects)
 	       ;; FIXME: Is it really right to look at *LEXENV* here,
 	       ;; instead of looking at the LEXENV argument? Why?
@@ -761,10 +767,11 @@
 			    (= inhibit-warnings 3)))) ;FIXME: really OK to suppress?
       (compiler-warn
        "The type ~S ~A conflicts with an enclosing assertion:~%   ~S"
-       (type-specifier ctype)
+       (type-specifier atype)
        place
-       (type-specifier old-type)))
-    (make-lexenv :type-restrictions `((,cont . ,new))
+       (type-specifier old-atype)))
+    (make-lexenv :type-restrictions `((,cont . ,new-atype))
+                 :weakend-type-restrictions `((,cont . ,new-ctype))
 		 :default lexenv)))
 
 ;;; Assert that FORM evaluates to the specified type (which may be a
@@ -841,7 +848,7 @@
 (defun setq-var (start cont var value)
   (declare (type continuation start cont) (type basic-var var))
   (let ((dest (make-continuation)))
-    (setf (continuation-asserted-type dest) (leaf-type var))
+    (assert-continuation-type dest (leaf-type var) (lexenv-policy *lexenv*))
     (ir1-convert start dest value)
     (let ((res (make-set :var var :value dest)))
       (setf (continuation-dest dest) res)
@@ -988,7 +995,8 @@
 		     `(%coerce-callable-to-fun ,fun)))
     (setf (continuation-dest fun-cont) node)
     (assert-continuation-type fun-cont
-			      (specifier-type '(or function symbol)))
+			      (specifier-type '(or function symbol))
+                              (lexenv-policy *lexenv*))
     (collect ((arg-conts))
       (let ((this-start fun-cont))
 	(dolist (arg args)
@@ -1038,6 +1046,7 @@
     (ir1-convert start dummy-start result)
 
     (with-continuation-type-assertion
+        ;; FIXME: policy
         (cont (continuation-asserted-type dummy-start)
               "of the first form")
       (substitute-continuation-uses cont dummy-start))
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 6fcb1e7..e4c633b 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -138,8 +138,9 @@
                     ;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)).
                     (fun-type-wild-args fun-type))
                 (progn (dolist (arg args)
-                         (setf (continuation-%externally-checkable-type arg)
-                               *wild-type*))
+                         (when arg
+                           (setf (continuation-%externally-checkable-type arg)
+                                 *wild-type*)))
                        *wild-type*)
                 (let* ((arg-types (append (fun-type-required fun-type)
                                           (fun-type-optional fun-type)
@@ -150,8 +151,9 @@
                   (loop
                      for arg of-type continuation in args
                      and type of-type ctype in arg-types
-                     do (setf (continuation-%externally-checkable-type arg)
-                              type))
+                     do (when arg
+                          (setf (continuation-%externally-checkable-type arg)
+                                type)))
                   (continuation-%externally-checkable-type cont)))))))
 
 ;;;; interface routines used by optimizers
@@ -187,15 +189,15 @@
       (setf (block-type-check (node-block node)) t)))
   (values))
 
-;;; Annotate Node to indicate that its result has been proven to be
-;;; typep to RType. After IR1 conversion has happened, this is the
+;;; Annotate NODE to indicate that its result has been proven to be
+;;; TYPEP to RTYPE. After IR1 conversion has happened, this is the
 ;;; only correct way to supply information discovered about a node's
-;;; type. If you screw with the Node-Derived-Type directly, then
+;;; type. If you screw with the NODE-DERIVED-TYPE directly, then
 ;;; information may be lost and reoptimization may not happen.
 ;;;
-;;; What we do is intersect Rtype with Node's Derived-Type. If the
+;;; What we do is intersect RTYPE with NODE's DERIVED-TYPE. If the
 ;;; intersection is different from the old type, then we do a
-;;; Reoptimize-Continuation on the Node-Cont.
+;;; REOPTIMIZE-CONTINUATION on the NODE-CONT.
 (defun derive-node-type (node rtype)
   (declare (type node node) (type ctype rtype))
   (let ((node-type (node-derived-type node)))
@@ -214,23 +216,34 @@
 	  (reoptimize-continuation (node-cont node))))))
   (values))
 
+(defun set-continuation-type-assertion (cont atype ctype)
+  (declare (type continuation cont) (type ctype atype ctype))
+  (when (eq atype *wild-type*)
+    (return-from set-continuation-type-assertion))
+  (let* ((old-atype (continuation-asserted-type cont))
+         (old-ctype (continuation-type-to-check cont))
+         (new-atype (values-type-intersection old-atype atype))
+         (new-ctype (values-type-intersection old-ctype ctype)))
+    (when (or (type/= old-atype new-atype)
+              (type/= old-ctype new-ctype))
+      (setf (continuation-asserted-type cont) new-atype)
+      (setf (continuation-type-to-check cont) new-ctype)
+      (do-uses (node cont)
+        (setf (block-attributep (block-flags (node-block node))
+                                type-check type-asserted)
+              t))
+      (reoptimize-continuation cont)))
+  (values))
+
 ;;; This is similar to DERIVE-NODE-TYPE, but asserts that it is an
 ;;; error for CONT's value not to be TYPEP to TYPE. If we improve the
 ;;; assertion, we set TYPE-CHECK and TYPE-ASSERTED to guarantee that
 ;;; the new assertion will be checked.
-(defun assert-continuation-type (cont type)
+(defun assert-continuation-type (cont type policy)
   (declare (type continuation cont) (type ctype type))
-  (let ((cont-type (continuation-asserted-type cont)))
-    (unless (eq cont-type type)
-      (let ((int (values-type-intersection cont-type type)))
-	(when (type/= cont-type int)
-	  (setf (continuation-asserted-type cont) int)
-	  (do-uses (node cont)
-	    (setf (block-attributep (block-flags (node-block node))
-				    type-check type-asserted)
-		  t))
-	  (reoptimize-continuation cont)))))
-  (values))
+  (when (eq type *wild-type*)
+    (return-from assert-continuation-type))
+  (set-continuation-type-assertion cont type (maybe-weaken-check type policy)))
 
 ;;; Assert that CALL is to a function of the specified TYPE. It is
 ;;; assumed that the call is legal and has only constants in the
@@ -238,20 +251,21 @@
 (defun assert-call-type (call type)
   (declare (type combination call) (type fun-type type))
   (derive-node-type call (fun-type-returns type))
-  (let ((args (combination-args call)))
+  (let ((args (combination-args call))
+        (policy (lexenv-policy (node-lexenv call))))
     (dolist (req (fun-type-required type))
       (when (null args) (return-from assert-call-type))
       (let ((arg (pop args)))
-	(assert-continuation-type arg req)))
+	(assert-continuation-type arg req policy)))
     (dolist (opt (fun-type-optional type))
       (when (null args) (return-from assert-call-type))
       (let ((arg (pop args)))
-	(assert-continuation-type arg opt)))
+	(assert-continuation-type arg opt policy)))
 
     (let ((rest (fun-type-rest type)))
       (when rest
 	(dolist (arg args)
-	  (assert-continuation-type arg rest))))
+	  (assert-continuation-type arg rest policy))))
 
     (dolist (key (fun-type-keywords type))
       (let ((name (key-info-name key)))
@@ -259,7 +273,8 @@
 	    ((null arg))
 	  (when (eq (continuation-value (first arg)) name)
 	    (assert-continuation-type
-	     (second arg) (key-info-type key)))))))
+	     (second arg) (key-info-type key)
+             policy))))))
   (values))
 
 ;;;; IR1-OPTIMIZE
@@ -1313,6 +1328,7 @@
   (let* ((ref (first (leaf-refs var)))
 	 (cont (node-cont ref))
 	 (cont-atype (continuation-asserted-type cont))
+         (cont-ctype (continuation-type-to-check cont))
 	 (dest (continuation-dest cont)))
     (when (and (eq (continuation-use cont) ref)
 	       dest
@@ -1329,7 +1345,7 @@
 		   (lexenv-policy (node-lexenv (continuation-dest arg)))))
       (aver (member (continuation-kind arg)
 		    '(:block-start :deleted-block-start :inside-block)))
-      (assert-continuation-type arg cont-atype)
+      (set-continuation-type-assertion arg cont-atype cont-ctype)
       (setf (node-derived-type ref) *wild-type*)
       (change-ref-leaf ref (find-constant nil))
       (substitute-continuation arg cont)
diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 4f9b4e5..776d279 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -330,11 +330,18 @@
     (push node-block (block-pred block))
     (add-continuation-use node cont)
     (unless (eq (continuation-asserted-type cont) *wild-type*)
-      (let ((new (values-type-union (continuation-asserted-type cont)
-				    (or (lexenv-find cont type-restrictions)
-					*wild-type*))))
-	(when (type/= new (continuation-asserted-type cont))
-	  (setf (continuation-asserted-type cont) new)
+      (let* ((restriction (or (lexenv-find cont type-restrictions)
+                              *wild-type*))
+             (wrestriction (or (lexenv-find cont weakend-type-restrictions)
+                               *wild-type*))
+             (newatype (values-type-union (continuation-asserted-type cont)
+                                          restriction))
+             (newctype (values-type-union (continuation-type-to-check cont)
+                                          wrestriction)))
+	(when (or (type/= newatype (continuation-asserted-type cont))
+                  (type/= newctype (continuation-type-to-check cont)))
+	  (setf (continuation-asserted-type cont) newatype)
+          (setf (continuation-type-to-check cont) newctype)
 	  (reoptimize-continuation cont))))))
 
 ;;;; exported functions
@@ -747,7 +754,8 @@
   (let ((node (make-combination fun-cont)))
     (setf (continuation-dest fun-cont) node)
     (assert-continuation-type fun-cont
-			      (specifier-type '(or function symbol)))
+			      (specifier-type '(or function symbol))
+                              (lexenv-policy *lexenv*))
     (setf (continuation-%externally-checkable-type fun-cont) nil)
     (collect ((arg-conts))
       (let ((this-start fun-cont))
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index c98f2bf..aa2eb57 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -387,7 +387,8 @@
 ;;; slot values. Values for the alist slots are NCONCed to the
 ;;; beginning of the current value, rather than replacing it entirely.
 (defun make-lexenv (&key (default *lexenv*)
-			 funs vars blocks tags type-restrictions
+			 funs vars blocks tags
+                         type-restrictions weakend-type-restrictions
 			 (lambda (lexenv-lambda default))
 			 (cleanup (lexenv-cleanup default))
 			 (policy (lexenv-policy default)))
@@ -402,6 +403,7 @@
      (frob blocks lexenv-blocks)
      (frob tags lexenv-tags)
      (frob type-restrictions lexenv-type-restrictions)
+     (frob weakend-type-restrictions lexenv-weakend-type-restrictions)
      lambda cleanup policy)))
 
 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced
@@ -429,6 +431,7 @@
      nil
      nil
      (lexenv-type-restrictions lexenv) ; XXX
+     (lexenv-weakend-type-restrictions lexenv)
      nil
      nil
      (lexenv-policy lexenv))))
@@ -883,6 +886,7 @@
   (setf (continuation-next cont) nil)
   (setf (continuation-asserted-type cont) *empty-type*)
   (setf (continuation-%derived-type cont) *empty-type*)
+  (setf (continuation-type-to-check cont) *empty-type*)
   (setf (continuation-use cont) nil)
   (setf (continuation-block cont) nil)
   (setf (continuation-reoptimize cont) nil)
@@ -1219,6 +1223,7 @@
 	  (setf (node-derived-type inside) *wild-type*)
 	  (flush-dest cont)
 	  (setf (continuation-asserted-type cont) *wild-type*)
+          (setf (continuation-type-to-check cont) *wild-type*)
 	  (values))))))
 
 ;;;; leaf hackery
diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index b916025..3d848ac 100644
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -291,7 +291,7 @@
 
     (cond ((and (eq (continuation-type-check cont) t)
 		(multiple-value-bind (check types)
-		    (continuation-check-types cont)
+		    (continuation-check-types cont nil)
 		  (aver (eq check :simple))
 		  ;; If the proven type is a subtype of the possibly
 		  ;; weakened type check then it's always true and is
@@ -323,7 +323,7 @@
 	 (nlocs (length locs)))
     (aver (= nlocs (length ptypes)))
     (if (eq (continuation-type-check cont) t)
-	(multiple-value-bind (check types) (continuation-check-types cont)
+	(multiple-value-bind (check types) (continuation-check-types cont nil)
 	  (aver (eq check :simple))
 	  (let ((ntypes (length types)))
 	    (mapcar (lambda (from to-type assertion)
diff --git a/src/compiler/lexenv.lisp b/src/compiler/lexenv.lisp
index 033a4fa..34f37ba 100644
--- a/src/compiler/lexenv.lisp
+++ b/src/compiler/lexenv.lisp
@@ -26,7 +26,9 @@
 					       '(debug . 1)
 					       '(inhibit-warnings . 1)))))
 	     (:constructor internal-make-lexenv
-			   (funs vars blocks tags type-restrictions
+			   (funs vars blocks tags
+                                 type-restrictions
+                                 weakend-type-restrictions
 				 lambda cleanup policy)))
   ;; an alist of (NAME . WHAT), where WHAT is either a FUNCTIONAL (a
   ;; local function), a DEFINED-FUN, representing an
@@ -56,6 +58,7 @@
   ;; THING is a continuation, this is used to track the innermost THE
   ;; type declaration.
   (type-restrictions nil :type list)
+  (weakend-type-restrictions nil :type list)
   ;; the lexically enclosing lambda, if any
   ;;
   ;; FIXME: This should be :TYPE (OR CLAMBDA NULL), but it was too hard
diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index ef4fc53..304142d 100644
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -40,7 +40,8 @@
     (let ((arg (car args))
 	  (var (car vars)))
       (cond ((leaf-refs var)
-	     (assert-continuation-type arg (leaf-type var)))
+	     (assert-continuation-type arg (leaf-type var)
+                                       (lexenv-policy (node-lexenv call))))
 	    (t
 	     (flush-dest arg)
 	     (setf (car args) nil)))))
@@ -456,7 +457,8 @@
       (assert-continuation-type
        (first (basic-combination-args call))
        (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep))
-			 :rest *universal-type*))))
+			 :rest *universal-type*)
+       (lexenv-policy (node-lexenv call)))))
   (values))
 
 ;;; Attempt to convert a call to a lambda. If the number of args is
@@ -867,7 +869,10 @@
 	  (cont (node-cont call))
 	  (call-type (node-derived-type call)))
       (when (eq (continuation-use cont) call)
-	(assert-continuation-type cont (continuation-asserted-type result)))
+        (set-continuation-type-assertion
+         cont
+         (continuation-asserted-type result)
+         (continuation-type-to-check result)))
       (unless (eq call-type *wild-type*)
 	(do-uses (use result)
 	  (derive-node-type use call-type)))
diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
index eff4303..5641114 100644
--- a/src/compiler/node.lisp
+++ b/src/compiler/node.lisp
@@ -127,6 +127,8 @@
   ;; This is computed lazily by CONTINUATION-DERIVED-TYPE, so use
   ;; CONTINUATION-TYPE-CHECK instead of the %'ed slot accessor.
   (%type-check t :type (member t nil :deleted :no-check))
+  ;; Asserted type, weakend according to policies
+  (type-to-check *wild-type* :type ctype)
   ;; Cached type which is checked by DEST. If NIL, then this must be
   ;; recomputed: see CONTINUATION-EXTERNALLY-CHECKABLE-TYPE.
   (%externally-checkable-type nil :type (or null ctype))
diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 1d5ce41..f3f1d20 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -578,6 +578,42 @@ BUG 48c, not yet fixed:
 ;;; (fix provided by Matthew Danish) on sbcl-devel
 (assert (null (ignore-errors
 		(defmacro bug172 (&rest rest foo) `(list ,rest ,foo)))))
+
+;;; embedded THEs
+(defun check-embedded-thes (policy1 policy2 x y)
+  (handler-case
+      (funcall (compile nil
+                        `(lambda (f)
+                           (declare (optimize (speed 2) (safety ,policy1)))
+                           (multiple-value-list
+                            (the (values (integer 2 3) t)
+                              (locally (declare (optimize (safety ,policy2)))
+                                (the (values t (single-float 2f0 3f0))
+                                  (funcall f)))))))
+               (lambda () (values x y)))
+    (type-error (error)
+      error)))
+
+(assert (equal (check-embedded-thes 0 0  :a :b) '(:a :b)))
+
+(assert (equal (check-embedded-thes 0 3  :a 2.5f0) '(:a 2.5f0)))
+(assert (typep (check-embedded-thes 0 3  2 3.5f0) 'type-error))
+
+(assert (equal (check-embedded-thes 0 1  :a 3.5f0) '(:a 3.5f0)))
+(assert (typep (check-embedded-thes 0 1  2 2.5d0) 'type-error))
+
+#+nil
+(assert (equal (check-embedded-thes 3 0  2 :a) '(2 :a)))
+(assert (typep (check-embedded-thes 3 0  4 2.5f0) 'type-error))
+
+(assert (equal (check-embedded-thes 1 0  4 :b) '(4 :b)))
+(assert (typep (check-embedded-thes 1 0  1.0 2.5f0) 'type-error))
+
+
+(assert (equal (check-embedded-thes 3 3  2 2.5f0) '(2 2.5f0)))
+(assert (typep (check-embedded-thes 3 3  0 2.5f0) 'type-error))
+(assert (typep (check-embedded-thes 3 3  2 3.5f0) 'type-error))
+
 
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
diff --git a/version.lisp-expr b/version.lisp-expr
index ace327a..6b9f789 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.9.40"
+"0.7.9.41"
-- 
1.7.10.4