From 419ce099442b9bffe41eff8516c6a2be085259de Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Thu, 29 Nov 2001 17:12:46 +0000 Subject: [PATCH] 0.pre7.86.flaky7.14: trivial changes made while hunting for the regression test bug --- BUGS | 14 +++++++ TODO | 1 + src/code/target-package.lisp | 2 +- src/compiler/debug.lisp | 6 +-- src/compiler/dfo.lisp | 2 +- src/compiler/ir1-translators.lisp | 6 +-- src/compiler/ir1util.lisp | 3 +- src/compiler/pack.lisp | 76 +++++++++++++++++++------------------ src/compiler/physenvanal.lisp | 19 +++++----- version.lisp-expr | 2 +- 10 files changed, 75 insertions(+), 56 deletions(-) diff --git a/BUGS b/BUGS index c7c5c47..e905d42 100644 --- 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.) +132: + Trying to compile + (DEFUN FOO () (CATCH 0 (PRINT 1331))) + gives an error + # 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 diff --git a/TODO b/TODO index 07a0194..a06c409 100644 --- 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 (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 diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 6e64443..035da80 100644 --- 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 - "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) diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index defa9ab..a9c1694 100644 --- 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))) -;;; 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 diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp index 1c24056..f509480 100644 --- 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) - ;; 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)) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index b8f657c..5f12ea2 100644 --- 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 -;;; 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 @@ -853,11 +853,11 @@ (%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 -;;; %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 diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 26a25a6..4f2eb6e 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -690,7 +690,8 @@ (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) diff --git a/src/compiler/pack.lisp b/src/compiler/pack.lisp index b0a9467..d7ae1ac 100644 --- a/src/compiler/pack.lisp +++ b/src/compiler/pack.lisp @@ -24,19 +24,21 @@ ;;;; 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. -;;; -- 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)) @@ -76,20 +78,20 @@ (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 -;;; 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)) @@ -186,7 +188,7 @@ (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)) @@ -257,9 +259,10 @@ (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)) @@ -275,8 +278,8 @@ ;;;; 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)) @@ -439,8 +442,9 @@ (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))) @@ -503,7 +507,7 @@ 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. ;;; @@ -569,8 +573,8 @@ (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))) diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index e319ef8..bfe514f 100644 --- 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. -;;; -- 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 @@ -280,14 +280,12 @@ (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)) - (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)))))) - (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)) - (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) - (note-non-local-exit target-env exit)))))) - + (note-non-local-exit target-physenv exit)))))) (values)) ;;;; 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 -;;; 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. diff --git a/version.lisp-expr b/version.lisp-expr index f472814..f4a439e 100644 --- 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".) -"0.pre7.86.flaky7.13" +"0.pre7.86.flaky7.14" -- 1.7.10.4