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.

diff --git a/BUGS b/BUGS
index e1e6c12..59f201f 100644 (file)
--- 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,
        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).
        (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).
        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"
   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))
        (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)
 
        ; in: LAMBDA NIL
        ;     (FOO :Y 1 :Y 2)

-       ; 
+       ;

        ; caught STYLE-WARNING:
        ;   The variable #:G15 is defined but never used.
 
        ; 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
   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
   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)
        (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
        (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.
      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:
 
 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))
       (when x
         (define-compiler-macro bar (&whole whole)
           (declare (ignore whole))

@@ -1260,7 +1260,7 @@ WORKAROUND:
   * (baz t)
   1
 
   * (baz t)
   1
 

-220: 
+220:

   Sbcl 0.7.9 fails to compile
 
   (multiple-value-call #'list
   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)
          (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.)
 
   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.
 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 (file)
--- 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"
              "DEFENUM"
              "DEFPRINTER"
              "AVER" "ENFORCE-TYPE"

+             "AWHEN" "ACOND" "IT"

 
             ;; ..and CONDITIONs..
             "BUG"
 
             ;; ..and CONDITIONs..
             "BUG"

@@ -793,6 +794,7 @@ retained, possibly temporariliy, because it might be used internally."
              ;; hash caches
              "DEFINE-HASH-CACHE"
              "DEFUN-CACHED"
              ;; hash caches
              "DEFINE-HASH-CACHE"
              "DEFUN-CACHED"

+             "DEFINE-CACHED-SYNONYM"

 
              ;; time
              "FORMAT-DECODED-TIME"
 
              ;; time
              "FORMAT-DECODED-TIME"

diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index e4fa9c5..a23f10f 100644 (file)
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -560,6 +560,19 @@
                             ,@(values-names))
                            (values ,@(values-names)))
                          (values ,@(values-names))))))))))))
                             ,@(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)))))
+

 \f
 ;;;; package idioms
 
 \f
 ;;;; 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))
   (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 (file)
--- 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)))
 (defstruct (values-type
            (:include args-type
                      (class-info (type-class-or-lose 'values)))

+            (:constructor %make-values-type)

            (:copier nil)))
            (:copier nil)))

+(define-cached-synonym make-values-type)

 
 (!define-type-class values)
 
 
 (!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)))
 ;;; 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 *.
                       (: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))
   (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
 
 ;;; 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)))
                                 (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:
 
 ;;; 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)
                                 (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)))
   (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 (file)
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -353,7 +353,7 @@
     res))
 
 (!def-type-translator values (&rest values)
     res))
 
 (!def-type-translator values (&rest values)

-  (let ((res (make-values-type)))
+  (let ((res (%make-values-type)))

     (parse-args-types values res)
     res))
 \f
     (parse-args-types values res)
     res))
 \f

@@ -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))
 (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)))
   (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)
        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)))
   (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)
                                         *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)))
   (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*)))
                                     simplified-types
                                     (every #'type-enumerable simplified-types)
                                     *empty-type*)))

@@ -2106,7 +2118,7 @@
                 *empty-type*))))))
 
 (!define-type-method (member :complex-intersection2) (type1 type2)
                 *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)
     (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)
                                       (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))))
 
 (!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))))

 \f
 ;;;; utilities shared between cross-compiler and target system
 
 \f
 ;;;; 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 (file)
--- 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)
 (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)
   (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.
 
 ;;; 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
 (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))
 
 (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)
   ;; 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))
   (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 (file)
--- 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)))))
            (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))))

 \f
 ;;;; checking strategy determination
 
 \f
 ;;;; 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.
 ;;; 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
                 (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.
 
 ;;; 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.
 ;;; 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)
   (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
 
 ;;; 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.
 ;;; 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))
   (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)))
        (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
 
 ;;; 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)
           (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)
                    ((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
 
                   ((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)
                    (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))
        (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))
   (values))

diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp
index 8ec2cfc..97923ac 100644 (file)
--- a/src/compiler/ctype.lisp
+++ b/src/compiler/ctype.lisp
@@ -742,7 +742,8 @@
         ((not really-assert) t)
         (t
          (when atype
         ((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
          (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"))))
 \f
                               :unwinnage-fun #'compiler-note
                               :where "proclamation"))))
 \f

-;;;;
+;;;; FIXME: Move to some other file.

 (defun check-catch-tag-type (tag)
   (declare (type continuation tag))
   (let ((ctype (continuation-type tag)))
 (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 (file)
--- 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)
 (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
     (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))
 ;;; 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))
     (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?
     (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"
                            (= 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
        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
                 :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)))
 (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)
     (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
                     `(%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)
     (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
     (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))
         (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 (file)
--- 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)
                     ;; 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)
                        *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
                   (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)))))))
 \f
 ;;;; interface routines used by optimizers
                   (continuation-%externally-checkable-type cont)))))))
 \f
 ;;;; interface routines used by optimizers

@@ -187,15 +189,15 @@
       (setf (block-type-check (node-block node)) t)))
   (values))
 
       (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
 ;;; 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.
 ;;;
 ;;; 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
 ;;; 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)))
 (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))
 
          (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.
 ;;; 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))
   (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
 
 ;;; 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))
 (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)))
     (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)))
     (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)
 
     (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)))
 
     (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
            ((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))
 \f
 ;;;; IR1-OPTIMIZE
   (values))
 \f
 ;;;; IR1-OPTIMIZE

@@ -1313,6 +1328,7 @@
   (let* ((ref (first (leaf-refs var)))
         (cont (node-cont ref))
         (cont-atype (continuation-asserted-type cont))
   (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
         (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)))
                   (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)
       (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 (file)
--- 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*)
     (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))))))
 \f
 ;;;; exported functions
          (reoptimize-continuation cont))))))
 \f
 ;;;; exported functions

@@ -747,7 +754,8 @@
   (let ((node (make-combination fun-cont)))
     (setf (continuation-dest fun-cont) node)
     (assert-continuation-type fun-cont
   (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))
     (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 (file)
--- 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*)
 ;;; 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)))
                         (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 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
      lambda cleanup policy)))
 
 ;;; Makes a LEXENV, suitable for using in a MACROLET introduced

@@ -429,6 +431,7 @@
      nil
      nil
      (lexenv-type-restrictions lexenv) ; XXX
      nil
      nil
      (lexenv-type-restrictions lexenv) ; XXX

+     (lexenv-weakend-type-restrictions lexenv)

      nil
      nil
      (lexenv-policy 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-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)
   (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 (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))))))
 \f
 ;;;; leaf hackery
          (values))))))
 \f
 ;;;; leaf hackery

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index b916025..3d848ac 100644 (file)
--- 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)
 
     (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
                  (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)
         (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)
          (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 (file)
--- a/src/compiler/lexenv.lisp
+++ b/src/compiler/lexenv.lisp
@@ -26,7 +26,9 @@
                                               '(debug . 1)
                                               '(inhibit-warnings . 1)))))
             (:constructor internal-make-lexenv
                                               '(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
                                 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)
   ;; 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
   ;; 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 (file)
--- 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)
     (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)))))
            (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))
       (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
   (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)
          (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)))
       (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 (file)
--- 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))
   ;; 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))
   ;; 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 (file)
--- 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)))))
 ;;; (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))
+

 \f
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
 \f
 ;;;; 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 (file)
--- 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".)
 
 ;;; 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"