0.pre7.86.flaky7.14:

	trivial changes made while hunting for the regression test bug

diff --git a/BUGS b/BUGS
index c7c5c47..e905d42 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -1286,6 +1286,20 @@ Error in function C::GET-LAMBDA-TO-COMPILE:
   arguments in FLET/LABELS: it might be an old Python bug which is 
   only exercised by the new arrangement of the SBCL compiler.)
 
   arguments in FLET/LABELS: it might be an old Python bug which is 
   only exercised by the new arrangement of the SBCL compiler.)
 

+132:
+  Trying to compile 
+    (DEFUN FOO () (CATCH 0 (PRINT 1331)))
+  gives an error
+    #<SB-C:TN '0!1> is not valid as the second argument to VOP:
+      SB-C:MAKE-CATCH-BLOCK,
+    since the TN's primitive type SB-VM::POSITIVE-FIXNUM doesn't allow
+    any of the SCs allowed by the operand restriction:
+     (SB-VM::DESCRIPTOR-REG)
+  The (CATCH 0 ...) construct is bad style (because of unportability
+  of EQ testing of numbers) but it is legal, and shouldn't cause an
+  internal compiler error. (This error occurs in sbcl-0.6.13 and in
+  0.pre7.86.flaky7.14.)
+

 KNOWN BUGS RELATED TO THE IR1 INTERPRETER
 
 (Now that the IR1 interpreter has gone away, these should be 
 KNOWN BUGS RELATED TO THE IR1 INTERPRETER
 
 (Now that the IR1 interpreter has gone away, these should be 

diff --git a/TODO b/TODO
index 07a0194..a06c409 100644 (file)
--- a/TODO
+++ b/TODO
@@ -8,6 +8,7 @@ for 0.7.0:
        ** made %COMPILE set up debugging data more like the way the
                debugger expects (and maybe even completely
                correctly:-)
        ** made %COMPILE set up debugging data more like the way the
                debugger expects (and maybe even completely
                correctly:-)

+               *** made (DISASSEMBLE 'PRINT) work

 * incompatible changes listed in NEWS:
        ** changed debugger prompt to "5]", "5[2]", "5[3]", etc.
        ** changed default output representation of *PRINT-ESCAPE*-ed
 * incompatible changes listed in NEWS:
        ** changed debugger prompt to "5]", "5[2]", "5[3]", etc.
        ** changed default output representation of *PRINT-ESCAPE*-ed

diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp
index 6e64443..035da80 100644 (file)
--- a/src/code/target-package.lisp
+++ b/src/code/target-package.lisp
@@ -834,7 +834,7 @@
 
 (defun unuse-package (packages-to-unuse &optional (package (sane-package)))
   #!+sb-doc
 
 (defun unuse-package (packages-to-unuse &optional (package (sane-package)))
   #!+sb-doc

-  "Remove Packages-To-Unuse from the use list for Package."
+  "Remove PACKAGES-TO-UNUSE from the USE list for PACKAGE."

   (let ((package (find-undeleted-package-or-lose package)))
     (dolist (p (package-listify packages-to-unuse))
       (setf (package-%use-list package)
   (let ((package (find-undeleted-package-or-lose package)))
     (dolist (p (package-listify packages-to-unuse))
       (setf (package-%use-list package)

diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp
index defa9ab..a9c1694 100644 (file)
--- a/src/compiler/debug.lisp
+++ b/src/compiler/debug.lisp
@@ -164,9 +164,9 @@
   (unless (gethash fun *seen-functions*)
     (barf "unseen function ~S in ~S" fun where)))
 
   (unless (gethash fun *seen-functions*)
     (barf "unseen function ~S in ~S" fun where)))
 

-;;; In a lambda, check that the associated nodes are in seen blocks. In an
-;;; optional dispatch, check that the entry points were seen. If the function
-;;; is deleted, ignore it.
+;;; In a CLAMBDA, check that the associated nodes are in seen blocks.
+;;; In an OPTIONAL-DISPATCH, check that the entry points were seen. If
+;;; the function is deleted, ignore it.

 (defun check-function-stuff (functional)
   (ecase (functional-kind functional)
     (:external
 (defun check-function-stuff (functional)
   (ecase (functional-kind functional)
     (:external

diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp
index 1c24056..f509480 100644 (file)
--- a/src/compiler/dfo.lisp
+++ b/src/compiler/dfo.lisp
@@ -339,7 +339,7 @@
     ;; between them. Any code that is left in an initial component
     ;; must be unreachable, so we can delete it. Stray links to the
     ;; initial component tail (due NIL function terminated blocks)
     ;; between them. Any code that is left in an initial component
     ;; must be unreachable, so we can delete it. Stray links to the
     ;; initial component tail (due NIL function terminated blocks)

-    ;; are moved to the appropriate newc component tail.
+    ;; are moved to the appropriate new component tail.

     (dolist (toplevel-lambda toplevel-lambdas)
       (let* ((block (lambda-block toplevel-lambda))
             (old-component (block-component block))
     (dolist (toplevel-lambda toplevel-lambdas)
       (let* ((block (lambda-block toplevel-lambda))
             (old-component (block-component block))

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index b8f657c..5f12ea2 100644 (file)
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -789,7 +789,7 @@
               `(multiple-value-call #'%throw ,tag ,result)))
 
 ;;; This is a special special form used to instantiate a cleanup as
               `(multiple-value-call #'%throw ,tag ,result)))
 
 ;;; This is a special special form used to instantiate a cleanup as

-;;; the current cleanup within the body. KIND is a the kind of cleanup
+;;; the current cleanup within the body. KIND is the kind of cleanup

 ;;; to make, and MESS-UP is a form that does the mess-up action. We
 ;;; make the MESS-UP be the USE of the MESS-UP form's continuation,
 ;;; and introduce the cleanup into the lexical environment. We
 ;;; to make, and MESS-UP is a form that does the mess-up action. We
 ;;; make the MESS-UP be the USE of the MESS-UP form's continuation,
 ;;; and introduce the cleanup into the lexical environment. We

@@ -853,11 +853,11 @@
            (%catch (%escape-function ,exit-block) ,tag)
          ,@body)))))
 
            (%catch (%escape-function ,exit-block) ,tag)
          ,@body)))))
 

-;;; UNWIND-PROTECT is similar to CATCH, but more hairy. We make the
+;;; UNWIND-PROTECT is similar to CATCH, but hairier. We make the

 ;;; cleanup forms into a local function so that they can be referenced
 ;;; both in the case where we are unwound and in any local exits. We
 ;;; use %CLEANUP-FUNCTION on this to indicate that reference by
 ;;; cleanup forms into a local function so that they can be referenced
 ;;; both in the case where we are unwound and in any local exits. We
 ;;; use %CLEANUP-FUNCTION on this to indicate that reference by

-;;; %UNWIND-PROTECT ISN'T "real", and thus doesn't cause creation of
+;;; %UNWIND-PROTECT isn't "real", and thus doesn't cause creation of

 ;;; an XEP.
 (def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
   #!+sb-doc
 ;;; an XEP.
 (def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
   #!+sb-doc

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 26a25a6..4f2eb6e 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -690,7 +690,8 @@
 
     (cond ((null refs)
           (typecase leaf
 
     (cond ((null refs)
           (typecase leaf

-            (lambda-var (delete-lambda-var leaf))
+            (lambda-var
+             (delete-lambda-var leaf))

             (clambda
              (ecase (functional-kind leaf)
                ((nil :let :mv-let :assignment :escape :cleanup)
             (clambda
              (ecase (functional-kind leaf)
                ((nil :let :mv-let :assignment :escape :cleanup)

diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp
index b0a9467..d7ae1ac 100644 (file)
--- a/src/compiler/pack.lisp
+++ b/src/compiler/pack.lisp
@@ -24,19 +24,21 @@
 \f
 ;;;; conflict determination
 
 \f
 ;;;; conflict determination
 

-;;; Return true if the element at the specified offset in SB has a conflict
-;;; with TN:
-;;; -- If an component-live TN (:component kind), then iterate over all the
-;;;    blocks. If the element at Offset is used anywhere in any of the
-;;;    component's blocks (always-live /= 0), then there is a conflict.
-;;; -- If TN is global (Confs true), then iterate over the blocks TN is live in
-;;;    (using TN-Global-Conflicts). If the TN is live everywhere in the block
-;;;    (:Live), then there is a conflict if the element at offset is used
-;;;    anywhere in the block (Always-Live /= 0). Otherwise, we use the local
-;;;    TN number for TN in block to find whether TN has a conflict at Offset in
+;;; Return true if the element at the specified offset in SB has a
+;;; conflict with TN:
+;;; -- If a component-live TN (:component kind), then iterate over
+;;;    all the blocks. If the element at Offset is used anywhere in
+;;;    any of the component's blocks (always-live /= 0), then there
+;;;    is a conflict.
+;;; -- If TN is global (Confs true), then iterate over the blocks TN
+;;;    is live in (using TN-Global-Conflicts). If the TN is live
+;;;    everywhere in the block (:LIVE), then there is a conflict
+;;;    if the element at offset is used anywhere in the block
+;;;    (Always-Live /= 0). Otherwise, we use the local TN number for
+;;;    TN in block to find whether TN has a conflict at Offset in

 ;;;    that block.
 ;;;    that block.

-;;; -- If TN is local, then we just check for a conflict in the block it is
-;;;    local to.
+;;; -- If TN is local, then we just check for a conflict in the block
+;;;    it is local to.

 (defun offset-conflicts-in-sb (tn sb offset)
   (declare (type tn tn) (type finite-sb sb) (type index offset))
   (let ((confs (tn-global-conflicts tn))
 (defun offset-conflicts-in-sb (tn sb offset)
   (declare (type tn tn) (type finite-sb sb) (type index offset))
   (let ((confs (tn-global-conflicts tn))

@@ -76,20 +78,20 @@
       (when (offset-conflicts-in-sb tn sb (+ offset i))
        (return t)))))
 
       (when (offset-conflicts-in-sb tn sb (+ offset i))
        (return t)))))
 

-;;; Add TN's conflicts into the conflicts for the location at Offset in SC.
-;;; We iterate over each location in TN, adding to the conflicts for that
-;;; location:
-;;; -- If TN is a :Component TN, then iterate over all the blocks, setting
-;;;    all of the local conflict bits and the always-live bit. This records a
-;;;    conflict with any TN that has a LTN number in the block, as well as with
-;;;    :Always-Live and :Environment TNs.
+;;; Add TN's conflicts into the conflicts for the location at OFFSET
+;;; in SC. We iterate over each location in TN, adding to the
+;;; conflicts for that location:
+;;; -- If TN is a :COMPONENT TN, then iterate over all the blocks,
+;;;    setting all of the local conflict bits and the always-live bit.
+;;;    This records a conflict with any TN that has a LTN number in
+;;;    the block, as well as with :ALWAYS-LIVE and :ENVIRONMENT TNs.

 ;;; -- If TN is global, then iterate over the blocks TN is live in. In
 ;;; -- If TN is global, then iterate over the blocks TN is live in. In

-;;;    addition to setting the always-live bit to represent the conflict with
-;;;    TNs live throughout the block, we also set bits in the local conflicts.
-;;;    If TN is :Always-Live in the block, we set all the bits, otherwise we or
-;;;    in the local conflict bits.
-;;; -- If the TN is local, then we just do the block it is local to, setting
-;;;    always-live and OR'ing in the local conflicts.
+;;;    addition to setting the always-live bit to represent the conflict
+;;;    with TNs live throughout the block, we also set bits in the
+;;;    local conflicts. If TN is :ALWAYS-LIVE in the block, we set all
+;;;    the bits, otherwise we OR in the local conflict bits.
+;;; -- If the TN is local, then we just do the block it is local to,
+;;;    setting always-live and OR'ing in the local conflicts.

 (defun add-location-conflicts (tn sc offset)
   (declare (type tn tn) (type sc sc) (type index offset))
   (let ((confs (tn-global-conflicts tn))
 (defun add-location-conflicts (tn sc offset)
   (declare (type tn tn) (type sc sc) (type index offset))
   (let ((confs (tn-global-conflicts tn))

@@ -186,7 +188,7 @@
          (setf (finite-sb-last-offset sb) 0))))))
 
 ;;; Expand the :Unbounded SB backing SC by either the initial size or
          (setf (finite-sb-last-offset sb) 0))))))
 
 ;;; Expand the :Unbounded SB backing SC by either the initial size or

-;;; the SC element size, whichever is larger. If Needed-Size is
+;;; the SC element size, whichever is larger. If NEEDED-SIZE is

 ;;; larger, then use that size.
 (defun grow-sc (sc &optional (needed-size 0))
   (declare (type sc sc) (type index needed-size))
 ;;; larger, then use that size.
 (defun grow-sc (sc &optional (needed-size 0))
   (declare (type sc sc) (type index needed-size))

@@ -257,9 +259,10 @@
                (make-array size
                            :initial-element
                            #-sb-xc #*
                (make-array size
                            :initial-element
                            #-sb-xc #*

-                           ;; The cross-compiler isn't very good at dumping
-                           ;; specialized arrays, so we delay construction of
-                           ;; this SIMPLE-BIT-VECTOR until runtime.
+                           ;; The cross-compiler isn't very good at
+                           ;; dumping specialized arrays, so we delay
+                           ;; construction of this SIMPLE-BIT-VECTOR
+                           ;; until runtime.

                            #+sb-xc (make-array 0 :element-type 'bit)))
 
          (fill nil (finite-sb-conflicts sb))
                            #+sb-xc (make-array 0 :element-type 'bit)))
 
          (fill nil (finite-sb-conflicts sb))

@@ -275,8 +278,8 @@
 \f
 ;;;; internal errors
 
 \f
 ;;;; internal errors
 

-;;; Give someone a hard time because there isn't any load function defined
-;;; to move from Src to Dest.
+;;; Give someone a hard time because there isn't any load function
+;;; defined to move from SRC to DEST.

 (defun no-load-function-error (src dest)
   (let* ((src-sc (tn-sc src))
         (src-name (sc-name src-sc))
 (defun no-load-function-error (src dest)
   (let* ((src-sc (tn-sc src))
         (src-name (sc-name src-sc))

@@ -439,8 +442,9 @@
       (pushnew tn (gethash vop (ir2-component-spilled-vops 2comp)))))
   (values))
 
       (pushnew tn (gethash vop (ir2-component-spilled-vops 2comp)))))
   (values))
 

-;;; Make a save TN for TN, pack it, and return it. We copy various conflict
-;;; information from the TN so that pack does the right thing.
+;;; Make a save TN for TN, pack it, and return it. We copy various
+;;; conflict information from the TN so that pack does the right
+;;; thing.

 (defun pack-save-tn (tn)
   (declare (type tn tn))
   (let ((res (make-tn 0 :save nil nil)))
 (defun pack-save-tn (tn)
   (declare (type tn tn))
   (let ((res (make-tn 0 :save nil nil)))

@@ -503,7 +507,7 @@
                           vop))
     (emit-operand-load node block save tn next)))
 
                           vop))
     (emit-operand-load node block save tn next)))
 

-;;; Return a VOP after which is an o.k. place to save the value of TN.
+;;; Return a VOP after which is an OK place to save the value of TN.

 ;;; For correctness, it is only required that this location be after
 ;;; any possible write and before any possible restore location.
 ;;;
 ;;; For correctness, it is only required that this location be after
 ;;; any possible write and before any possible restore location.
 ;;;

@@ -569,8 +573,8 @@
           (save-complex-writer-tn tn vop))))
   (values))
 
           (save-complex-writer-tn tn vop))))
   (values))
 

-;;; Scan over the VOPs in Block, emiting saving code for TNs noted in the
-;;; codegen info that are packed into saved SCs.
+;;; Scan over the VOPs in BLOCK, emiting saving code for TNs noted in
+;;; the codegen info that are packed into saved SCs.

 (defun emit-saves (block)
   (declare (type ir2-block block))
   (do ((vop (ir2-block-start-vop block) (vop-next vop)))
 (defun emit-saves (block)
   (declare (type ir2-block block))
   (do ((vop (ir2-block-start-vop block) (vop-next vop)))

diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp
index e319ef8..bfe514f 100644 (file)
--- a/src/compiler/physenvanal.lisp
+++ b/src/compiler/physenvanal.lisp
@@ -266,8 +266,8 @@
 ;;; -- If there isn't any NLX-Info entry in the environment, make
 ;;;    an entry stub, otherwise just move the exit block link to
 ;;;    the component tail.
 ;;; -- If there isn't any NLX-Info entry in the environment, make
 ;;;    an entry stub, otherwise just move the exit block link to
 ;;;    the component tail.

-;;; -- Close over the NLX-Info in the exit environment.
-;;; -- If the exit is from an :Escape function, then substitute a
+;;; -- Close over the NLX-INFO in the exit environment.
+;;; -- If the exit is from an :ESCAPE function, then substitute a

 ;;;    constant reference to NLX-Info structure for the escape
 ;;;    function reference. This will cause the escape function to
 ;;;    be deleted (although not removed from the DFO.)  The escape
 ;;;    constant reference to NLX-Info structure for the escape
 ;;;    function reference. This will cause the escape function to
 ;;;    be deleted (although not removed from the DFO.)  The escape

@@ -280,14 +280,12 @@
   (let ((entry (exit-entry exit))
        (cont (node-cont exit))
        (exit-fun (node-home-lambda exit)))
   (let ((entry (exit-entry exit))
        (cont (node-cont exit))
        (exit-fun (node-home-lambda exit)))

-

     (if (find-nlx-info entry cont)
        (let ((block (node-block exit)))
          (aver (= (length (block-succ block)) 1))
          (unlink-blocks block (first (block-succ block)))
          (link-blocks block (component-tail (block-component block))))
        (insert-nlx-entry-stub exit env))
     (if (find-nlx-info entry cont)
        (let ((block (node-block exit)))
          (aver (= (length (block-succ block)) 1))
          (unlink-blocks block (first (block-succ block)))
          (link-blocks block (component-tail (block-component block))))
        (insert-nlx-entry-stub exit env))

-

     (let ((info (find-nlx-info entry cont)))
       (aver info)
       (close-over info (node-physenv exit) env)
     (let ((info (find-nlx-info entry cont)))
       (aver info)
       (close-over info (node-physenv exit) env)

@@ -299,7 +297,6 @@
        (let ((node (block-last (nlx-info-target info))))
          (delete-continuation-use node)
          (add-continuation-use node (nlx-info-continuation info))))))
        (let ((node (block-last (nlx-info-target info))))
          (delete-continuation-use node)
          (add-continuation-use node (nlx-info-continuation info))))))

-

   (values))
 
 ;;; Iterate over the EXITs in COMPONENT, calling NOTE-NON-LOCAL-EXIT
   (values))
 
 ;;; Iterate over the EXITs in COMPONENT, calling NOTE-NON-LOCAL-EXIT

@@ -312,11 +309,10 @@
   (dolist (lambda (component-lambdas component))
     (dolist (entry (lambda-entries lambda))
       (dolist (exit (entry-exits entry))
   (dolist (lambda (component-lambdas component))
     (dolist (entry (lambda-entries lambda))
       (dolist (exit (entry-exits entry))

-       (let ((target-env (node-physenv entry)))
-         (if (eq (node-physenv exit) target-env)
+       (let ((target-physenv (node-physenv entry)))
+         (if (eq (node-physenv exit) target-physenv)

              (maybe-delete-exit exit)
              (maybe-delete-exit exit)

-             (note-non-local-exit target-env exit))))))
-
+             (note-non-local-exit target-physenv exit))))))

   (values))
 \f
 ;;;; cleanup emission
   (values))
 \f
 ;;;; cleanup emission

@@ -326,7 +322,10 @@
 ;;; in an implicit MV-PROG1. We have to force local call analysis of
 ;;; new references to UNWIND-PROTECT cleanup functions. If we don't
 ;;; actually have to do anything, then we don't insert any cleanup
 ;;; in an implicit MV-PROG1. We have to force local call analysis of
 ;;; new references to UNWIND-PROTECT cleanup functions. If we don't
 ;;; actually have to do anything, then we don't insert any cleanup

-;;; code.
+;;; code. (FIXME: There's some confusion here, left over from CMU CL
+;;; comments. CLEANUP1 isn't mentioned in the code of this function.
+;;; It is in code elsewhere, but if the comments for this function
+;;; mention it they should explain the relationship to the other code.)

 ;;;
 ;;; If we do insert cleanup code, we check that BLOCK1 doesn't end in
 ;;; a "tail" local call.
 ;;;
 ;;; If we do insert cleanup code, we check that BLOCK1 doesn't end in
 ;;; a "tail" local call.

diff --git a/version.lisp-expr b/version.lisp-expr
index f472814..f4a439e 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 

-"0.pre7.86.flaky7.13"
+"0.pre7.86.flaky7.14"