From c7dc5b2a1f56ed0583a0b3ea61b6ceb540c6f89e Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Sat, 16 Nov 2002 10:26:13 +0000 Subject: [PATCH] 0.7.9.52: * Fixed bug: loop-for-as-package does not require package to be explicitely specified; * PRINT-IR2-BLOCKS shows corresponding IR1 block numbers. --- BUGS | 34 ++++++++++ NEWS | 4 +- src/code/loop.lisp | 11 ++-- src/compiler/debug.lisp | 162 +++++++++++++++++++++++++++-------------------- src/compiler/node.lisp | 4 +- src/compiler/tn.lisp | 3 +- src/compiler/vop.lisp | 2 + tests/loop.pure.lisp | 3 + version.lisp-expr | 2 +- 9 files changed, 146 insertions(+), 79 deletions(-) diff --git a/BUGS b/BUGS index c746255..c3ad6f9 100644 --- a/BUGS +++ b/BUGS @@ -522,6 +522,40 @@ WORKAROUND: internal error, failed AVER: "(COMMON-LISP:EQ (SB!C::TN-ENVIRONMENT SB!C:TN) SB!C::TN-ENV)" + This examples better illustrates the problem: + + (defun tst () + (declare (optimize (speed 2) (debug 3))) + (flet ((m1 () + (bar (if (foo) 1 2)) + (let ((x (foo))) + (bar x (list x))))) + (if (catch nil) + (m1) + (m1)))) + + (X is allocated in the physical environment of M1; X is :WRITE in + the call of LET [convert-to-global]; IF makes sure that a block + exists in M1 before this call.) + + Because X is :DEBUG-ENVIRONMENT, it is :LIVE by default in all + blocks in the environment, particularly it is :LIVE in the start of + M1 (where it is not yet :WRITE) [setup-environment-tn-conflicts]. + + Then :LIVE is propagated backwards, i.e. into the caller of M1 + where X does not exist [lifetime-flow-analysis]. + + (CATCH NIL) causes all TNs to be saved; Python fails on saving + non-existent variable; if it is replaced with (FOO), the problem + appears when debugging TST: LIST-LOCALS says + + debugger invoked on condition of type SB-DI:UNKNOWN-DEBUG-VAR: + + # is not in #. + + (in those old versions, in which debugger worked :-(). + 117: When the compiler inline expands functions, it may be that different kinds of return values are generated from different code branches. diff --git a/NEWS b/NEWS index 92ee4a4..0ab4e51 100644 --- a/NEWS +++ b/NEWS @@ -1397,7 +1397,9 @@ changes in sbcl-0.7.10 relative to sbcl-0.7.9: symbol-macro places; ** NCONC accepts any object as its last argument ** :COUNT argument to sequence functions may be BIGNUM (thanks to - Gerd Moellman) + Gerd Moellman); + ** Loop-package does not require a package to be explicitely + specified; * fixed bug 166: compiler preserves "there is a way to go" invariant when deleting code. * fixed bug 172: macro lambda lists with required arguments after diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 10a92ec..d6e83a9 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -1826,18 +1826,19 @@ code to be loaded. (defun loop-package-symbols-iteration-path (variable data-type prep-phrases &key symbol-types) - (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of)))) + (cond ((and prep-phrases (cdr prep-phrases)) (loop-error "Too many prepositions!")) - ((null prep-phrases) - (loop-error "missing OF or IN in ~S iteration path"))) + ((and prep-phrases (not (member (caar prep-phrases) '(:in :of)))) + (sb!int:bug "Unknown preposition ~S." (caar prep-phrases)))) (unless (symbolp variable) (loop-error "Destructuring is not valid for package symbol iteration.")) (let ((pkg-var (gensym "LOOP-PKGSYM-")) (next-fn (gensym "LOOP-PKGSYM-NEXT-")) - (variable (or variable (gensym "LOOP-PKGSYM-VAR-")))) + (variable (or variable (gensym "LOOP-PKGSYM-VAR-"))) + (package (or (cadar prep-phrases) '*package*))) (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types)) *loop-wrappers*) - `(((,variable nil ,data-type) (,pkg-var ,(cadar prep-phrases))) + `(((,variable nil ,data-type) (,pkg-var ,package)) () () () diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index b6e2753..7f67f0f 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -949,56 +949,58 @@ ;;; representing what the code does. (defun print-nodes (block) (setq block (block-or-lose block)) - (format t "~%block start c~D" (cont-num (block-start block))) - - (let ((last (block-last block))) - (terpri) - (do ((cont (block-start block) (node-cont (continuation-next cont)))) - (()) - (let ((node (continuation-next cont))) - (format t "~3D: " (cont-num (node-cont node))) - (etypecase node - (ref (print-leaf (ref-leaf node))) - (basic-combination - (let ((kind (basic-combination-kind node))) - (format t "~(~A ~A~) c~D" - (if (fun-info-p kind) "known" kind) - (type-of node) - (cont-num (basic-combination-fun node))) - (dolist (arg (basic-combination-args node)) - (if arg - (print-continuation arg) - (format t " "))))) - (cset - (write-string "set ") - (print-leaf (set-var node)) - (print-continuation (set-value node))) - (cif - (format t "if c~D" (cont-num (if-test node))) - (print-continuation (block-start (if-consequent node))) - (print-continuation (block-start (if-alternative node)))) - (bind - (write-string "bind ") - (print-leaf (bind-lambda node))) - (creturn - (format t "return c~D " (cont-num (return-result node))) - (print-leaf (return-lambda node))) - (entry - (format t "entry ~S" (entry-exits node))) - (exit - (let ((value (exit-value node))) - (cond (value - (format t "exit c~D" (cont-num value))) - ((exit-entry node) - (format t "exit ")) - (t - (format t "exit ")))))) - (terpri) - (when (eq node last) (return))))) - - (let ((succ (block-succ block))) - (format t "successors~{ c~D~}~%" - (mapcar (lambda (x) (cont-num (block-start x))) succ))) + (pprint-logical-block (nil nil) + (format t "~:@_IR1 block ~D start c~D" + (block-number block) (cont-num (block-start block))) + + (let ((last (block-last block))) + (pprint-newline :mandatory) + (do ((cont (block-start block) (node-cont (continuation-next cont)))) + ((not cont)) + (let ((node (continuation-next cont))) + (format t "~3D: " (cont-num (node-cont node))) + (etypecase node + (ref (print-leaf (ref-leaf node))) + (basic-combination + (let ((kind (basic-combination-kind node))) + (format t "~(~A ~A~) c~D" + (if (fun-info-p kind) "known" kind) + (type-of node) + (cont-num (basic-combination-fun node))) + (dolist (arg (basic-combination-args node)) + (if arg + (print-continuation arg) + (format t " "))))) + (cset + (write-string "set ") + (print-leaf (set-var node)) + (print-continuation (set-value node))) + (cif + (format t "if c~D" (cont-num (if-test node))) + (print-continuation (block-start (if-consequent node))) + (print-continuation (block-start (if-alternative node)))) + (bind + (write-string "bind ") + (print-leaf (bind-lambda node))) + (creturn + (format t "return c~D " (cont-num (return-result node))) + (print-leaf (return-lambda node))) + (entry + (format t "entry ~S" (entry-exits node))) + (exit + (let ((value (exit-value node))) + (cond (value + (format t "exit c~D" (cont-num value))) + ((exit-entry node) + (format t "exit ")) + (t + (format t "exit ")))))) + (pprint-newline :mandatory) + (when (eq node last) (return))))) + + (let ((succ (block-succ block))) + (format t "successors~{ c~D~}~%" + (mapcar (lambda (x) (cont-num (block-start x))) succ)))) (values)) ;;; Print the guts of a TN. (logic shared between PRINT-OBJECT (TN T) @@ -1050,27 +1052,29 @@ (when (vop-results vop) (princ "=> ") (print-operands (vop-results vop)))) - (terpri)) + (pprint-newline :mandatory)) ;;; Print the VOPs in the specified IR2 block. (defun print-ir2-block (block) (declare (type ir2-block block)) - (cond - ((eq (block-info (ir2-block-block block)) block) - (format t "~%IR2 block start c~D~%" - (cont-num (block-start (ir2-block-block block)))) - (let ((label (ir2-block-%label block))) - (when label - (format t "L~D:~%" (label-id label))))) - (t - (format t "~%"))) - - (do ((vop (ir2-block-start-vop block) - (vop-next vop)) - (number 0 (1+ number))) - ((null vop)) - (format t "~W: " number) - (print-vop vop))) + (pprint-logical-block (*standard-output* nil) + (cond + ((eq (block-info (ir2-block-block block)) block) + (format t "~:@_IR2 block ~D start c~D~:@_" + (ir2-block-number block) + (cont-num (block-start (ir2-block-block block)))) + (let ((label (ir2-block-%label block))) + (when label + (format t "L~D:~:@_" (label-id label))))) + (t + (format t "~:@_"))) + + (do ((vop (ir2-block-start-vop block) + (vop-next vop)) + (number 0 (1+ number))) + ((null vop)) + (format t "~W: " number) + (print-vop vop)))) ;;; This is like PRINT-NODES, but dumps the IR2 representation of the ;;; code in BLOCK. @@ -1084,9 +1088,24 @@ (values)) ;;; Scan the IR2 blocks in emission order. -(defun print-ir2-blocks (thing) - (do-ir2-blocks (block (block-component (block-or-lose thing))) - (print-ir2-block block)) +(defun print-ir2-blocks (thing &optional full) + (let* ((block (component-head (block-component (block-or-lose thing)))) + (2block (block-info block))) + (pprint-logical-block (nil nil) + (loop while 2block + do (setq block (ir2-block-block 2block)) + do (pprint-logical-block (*standard-output* nil) + (if full + (print-nodes block) + (format t "IR1 block ~D start c~D" + (block-number block) + (cont-num (block-start block)))) + (pprint-indent :block 4) + (pprint-newline :mandatory) + (loop while (and 2block (eq (ir2-block-block 2block) block)) + do (print-ir2-block 2block) + do (setq 2block (ir2-block-next 2block)))) + do (pprint-newline :mandatory)))) (values)) ;;; Do a PRINT-NODES on BLOCK and all blocks reachable from it by @@ -1156,6 +1175,9 @@ (clrhash *list-conflicts-table*) (do ((conf confs (global-conflicts-next-tnwise conf))) ((null conf)) + (format t "~&#~%" + (block-number (ir2-block-block (global-conflicts-block conf))) + (global-conflicts-kind conf)) (let ((block (global-conflicts-block conf))) (add-always-live-tns block tn) (if (eq (global-conflicts-kind conf) :live) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 5641114..ce43926 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -311,7 +311,9 @@ (test-constraint nil :type (or sset null))) (def!method print-object ((cblock cblock) stream) (print-unreadable-object (cblock stream :type t :identity t) - (format stream ":START c~W" (cont-num (block-start cblock))))) + (format stream "~W :START c~W" + (block-number cblock) + (cont-num (block-start cblock))))) ;;; The BLOCK-ANNOTATION class is inherited (via :INCLUDE) by ;;; different BLOCK-INFO annotation structures so that code diff --git a/src/compiler/tn.lisp b/src/compiler/tn.lisp index 18e9ca6..3b07aac 100644 --- a/src/compiler/tn.lisp +++ b/src/compiler/tn.lisp @@ -442,6 +442,7 @@ ;;; Return the value of an immediate constant TN. (defun tn-value (tn) (declare (type tn tn)) + ;; FIXME: What is :CACHED-CONSTANT? (aver (member (tn-kind tn) '(:constant :cached-constant))) (constant-value (tn-leaf tn))) @@ -455,7 +456,7 @@ (unless (and (not (sc-save-p sc)) (eq (sb-kind (sc-sb sc)) :unbounded)) (dolist (alt (sc-alternate-scs sc) - (error "SC ~S has no :unbounded :save-p NIL alternate SC." + (error "SC ~S has no :UNBOUNDED :SAVE-P NIL alternate SC." (sc-name sc))) (when (and (not (sc-save-p alt)) (eq (sb-kind (sc-sb alt)) :unbounded)) diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index 2c2e387..c6c6509 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -242,6 +242,8 @@ ;; CONSTANT-TNs are non-packed TNs that represent constants. ;; :CONSTANT TNs may eventually be converted to :CACHED-CONSTANT ;; normal TNs. + ;; + ;; FIXME: What is :CACHED-CONSTANT? (normal-tns nil :type (or tn null)) (restricted-tns nil :type (or tn null)) (wired-tns nil :type (or tn null)) diff --git a/tests/loop.pure.lisp b/tests/loop.pure.lisp index 77653bc..bed64e1 100644 --- a/tests/loop.pure.lisp +++ b/tests/loop.pure.lisp @@ -80,3 +80,6 @@ (assert (= (loop for nil being the external-symbols of :cl count t) 978)) (assert (= (loop for x being the external-symbols of :cl count x) 977)) + +(let ((*package* (find-package :cl))) + (assert (= (loop for x being each external-symbol count t) 978))) diff --git a/version.lisp-expr b/version.lisp-expr index 09f572a..01f351a 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.9.51" +"0.7.9.52" -- 1.7.10.4