From: Alexey Dejneka Date: Tue, 24 Jun 2003 04:36:37 +0000 (+0000) Subject: 0.8.1.1: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;ds=inline;h=85029815128ff53d16013d51ad0beb79b0eb3744;p=sbcl.git 0.8.1.1: * Fix bug 148: clean new blocks after failed inline expanding. --- diff --git a/BUGS b/BUGS index 677a4fc..97a6721 100644 --- a/BUGS +++ b/BUGS @@ -566,29 +566,6 @@ WORKAROUND: See also bugs #45.c and #183 -148: - COMPILE-FILE on the file - (defun u-b-sra (ad0) - (declare (special *foo* *bar*)) - (declare (optimize (safety 3) (speed 2) (space 1))) - (labels ((c.frob ()) - (ad.frob (ad) - (if *foo* - (mapc #'ad.frob *bar*) - (dolist (b *bar*) - (c.frob))))) - (declare (inline c.frob ad.frob)) - (ad.frob ad0))) - fails with - debugger invoked on condition of type TYPE-ERROR: - The value NIL is not of type SB-C::NODE. - - (Python LET-converts C.FROB into AD.FROB, then tries to inline - expand AD.FROB. Having partially done it, it sees a call of C.FROB, - which already does not exist. So it gives up on expansion, leaving - garbage consisting of infinished blocks of the partially converted - function.) - 162: (reported by Robert E. Brown 2002-04-16) When a function is called with too few arguments, causing the @@ -1061,6 +1038,21 @@ WORKAROUND: currently checks for complex arrays seem to be performed by callees.) +258: + Compiler fails on + + (defun u-b-sra (ad0) + (declare (special *foo* *bar*)) + (declare (optimize (safety 3) (speed 2) (space 1) (debug 1))) + (labels ((c.frob (x) + (random x)) + (ad.frob (ad) + (mapcar #'c.frob ad))) + (declare (inline c.frob ad.frob)) + (list (the list ad0) + (funcall (if (listp ad0) #'ad.frob #'print) ad0) + (funcall (if (listp ad0) #'ad.frob #'print) (reverse ad0))))) + DEFUNCT CATEGORIES OF BUGS IR1-#: These labels were used for bugs related to the old IR1 interpreter. diff --git a/NEWS b/NEWS index ffc99dc..d0f4126 100644 --- a/NEWS +++ b/NEWS @@ -1879,6 +1879,10 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0: treated by SLOT-BOUNDP, SLOT-VALUE, (SETF SLOT-VALUE) and SLOT-MAKUNBOUND in the specified fashion. +changes in sbcl-0.8.1 relative to sbcl-0.8.0: + * fixed bug 148: failure to inline-expand a local function left + garbage, confusing the compiler. + planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles down, it might impact TRACE. They both encapsulate functions, and diff --git a/src/code/array.lisp b/src/code/array.lisp index 2b817a3..5f0709f 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -388,7 +388,7 @@ (let ((index (car subs)) (dim (%array-dimension array axis))) (declare (fixnum dim)) - (unless (< -1 index dim) + (unless (and (fixnump index) (< -1 index dim)) (if invalid-index-error-p (error 'simple-type-error :format-control "invalid index ~W~[~;~:; on axis ~:*~W~] in ~S" @@ -400,7 +400,7 @@ (setf chunk-size (* chunk-size dim)))) (let ((index (first subscripts)) (length (length (the (simple-array * (*)) array)))) - (unless (< -1 index length) + (unless (and (fixnump index) (< -1 index length)) (if invalid-index-error-p ;; FIXME: perhaps this should share a format-string ;; with INVALID-ARRAY-INDEX-ERROR or @@ -415,7 +415,7 @@ (defun array-in-bounds-p (array &rest subscripts) #!+sb-doc - "Return T if the Subscipts are in bounds for the Array, Nil otherwise." + "Return T if the SUBSCIPTS are in bounds for the ARRAY, NIL otherwise." (if (%array-row-major-index array subscripts nil) t)) @@ -424,7 +424,7 @@ (defun aref (array &rest subscripts) #!+sb-doc - "Return the element of the Array specified by the Subscripts." + "Return the element of the ARRAY specified by the SUBSCRIPTS." (row-major-aref array (%array-row-major-index array subscripts))) (defun %aset (array &rest stuff) diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 8ed6283..d55bdeb 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -285,13 +285,11 @@ (let* ((bind (make-bind)) (lambda (make-lambda :vars vars - :bind bind - :%source-name source-name - :%debug-name debug-name)) + :bind bind + :%source-name source-name + :%debug-name debug-name)) (result (or result (make-continuation)))) - (continuation-starts-block result) - ;; just to check: This function should fail internal assertions if ;; we didn't set up a valid debug name above. ;; @@ -302,7 +300,7 @@ (setf (lambda-home lambda) lambda) (collect ((svars) - (new-venv nil cons)) + (new-venv nil cons)) (dolist (var vars) ;; As far as I can see, LAMBDA-VAR-HOME should never have @@ -324,27 +322,28 @@ (setf (bind-lambda bind) lambda) (setf (node-lexenv bind) *lexenv*) - (let ((cont1 (make-continuation)) - (cont2 (make-continuation))) - (continuation-starts-block cont1) - (link-node-to-previous-continuation bind cont1) - (use-continuation bind cont2) - (ir1-convert-special-bindings cont2 result body - aux-vars aux-vals (svars))) - - (let ((block (continuation-block result))) - (when block - (let ((return (make-return :result result :lambda lambda)) - (tail-set (make-tail-set :funs (list lambda))) - (dummy (make-continuation))) - (setf (lambda-tail-set lambda) tail-set) - (setf (lambda-return lambda) return) - (setf (continuation-dest result) return) - (flush-continuation-externally-checkable-type result) - (setf (block-last block) return) - (link-node-to-previous-continuation return result) - (use-continuation return dummy)) - (link-blocks block (component-tail *current-component*)))))) + (let ((block (continuation-starts-block result))) + (let ((return (make-return :result result :lambda lambda)) + (tail-set (make-tail-set :funs (list lambda))) + (dummy (make-continuation))) + (setf (lambda-tail-set lambda) tail-set) + (setf (lambda-return lambda) return) + (setf (continuation-dest result) return) + (flush-continuation-externally-checkable-type result) + (setf (block-last block) return) + (link-node-to-previous-continuation return result) + (use-continuation return dummy)) + (link-blocks block (component-tail *current-component*))) + + (with-component-last-block (*current-component* + (continuation-block result)) + (let ((cont1 (make-continuation)) + (cont2 (make-continuation))) + (continuation-starts-block cont1) + (link-node-to-previous-continuation bind cont1) + (use-continuation bind cont2) + (ir1-convert-special-bindings cont2 result body + aux-vars aux-vals (svars)))))) (link-blocks (component-head *current-component*) (node-block bind)) (push lambda (component-new-functionals *current-component*)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 02797be..74f5a20 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1070,18 +1070,20 @@ ;;; We mark the START as has having no next and remove the last node ;;; from its CONT's uses. We also flush the DEST for all continuations ;;; whose values are received by nodes in the block. -(defun delete-block (block) +(defun delete-block (block &optional silent) (declare (type cblock block)) (aver (block-component block)) ; else block is already deleted! - (note-block-deletion block) + (unless silent + (note-block-deletion block)) (setf (block-delete-p block) t) - (let* ((last (block-last block)) - (cont (node-cont last))) - (delete-continuation-use last) - (if (eq (continuation-kind cont) :unused) - (delete-continuation cont) - (reoptimize-continuation cont))) + (let ((last (block-last block))) + (when last + (let ((cont (node-cont last))) + (delete-continuation-use last) + (if (eq (continuation-kind cont) :unused) + (delete-continuation cont) + (reoptimize-continuation cont))))) (dolist (b (block-pred block)) (unlink-blocks b block) @@ -1095,7 +1097,7 @@ (dolist (b (block-succ block)) (unlink-blocks block b)) - (do-nodes (node cont block) + (do-nodes-carefully (node cont block) (typecase node (ref (delete-ref node)) (cif @@ -1106,42 +1108,42 @@ ;; careful that this LET has not already been partially deleted. (basic-combination (when (and (eq (basic-combination-kind node) :local) - ;; Guards COMBINATION-LAMBDA agains the REF being deleted. - (continuation-use (basic-combination-fun node))) - (let ((fun (combination-lambda node))) - ;; If our REF was the second-to-last ref, and has been - ;; deleted, then FUN may be a LET for some other - ;; combination. - (when (and (functional-letlike-p fun) - (eq (let-combination fun) node)) - (delete-lambda fun)))) + ;; Guards COMBINATION-LAMBDA agains the REF being deleted. + (continuation-use (basic-combination-fun node))) + (let ((fun (combination-lambda node))) + ;; If our REF was the second-to-last ref, and has been + ;; deleted, then FUN may be a LET for some other + ;; combination. + (when (and (functional-letlike-p fun) + (eq (let-combination fun) node)) + (delete-lambda fun)))) (flush-dest (basic-combination-fun node)) (dolist (arg (basic-combination-args node)) - (when arg (flush-dest arg)))) + (when arg (flush-dest arg)))) (bind (let ((lambda (bind-lambda node))) - (unless (eq (functional-kind lambda) :deleted) - (delete-lambda lambda)))) + (unless (eq (functional-kind lambda) :deleted) + (delete-lambda lambda)))) (exit (let ((value (exit-value node)) - (entry (exit-entry node))) - (when value - (flush-dest value)) - (when entry - (setf (entry-exits entry) - (delete node (entry-exits entry)))))) + (entry (exit-entry node))) + (when value + (flush-dest value)) + (when entry + (setf (entry-exits entry) + (delete node (entry-exits entry)))))) (creturn (flush-dest (return-result node)) (delete-return node)) (cset (flush-dest (set-value node)) (let ((var (set-var node))) - (setf (basic-var-sets var) - (delete node (basic-var-sets var))))) + (setf (basic-var-sets var) + (delete node (basic-var-sets var))))) (cast (flush-dest (cast-value node)))) - (delete-continuation (node-prev node))) + (delete-continuation (node-prev node))) (remove-from-dfo block) (values)) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index be089db..360c241 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -334,27 +334,35 @@ (>= speed compilation-speed))) (not (eq (functional-kind (node-home-lambda call)) :external)) (inline-expansion-ok call)) - (multiple-value-bind (losing-local-functional converted-lambda) - (catch 'locall-already-let-converted - (with-ir1-environment-from-node call - (let ((*lexenv* (functional-lexenv original-functional))) - (values nil - (ir1-convert-lambda - (functional-inline-expansion original-functional) - :debug-name (debug-namify - "local inline ~A" - (leaf-debug-name - original-functional))))))) - (cond (losing-local-functional - (let ((*compiler-error-context* call)) - (compiler-notify "couldn't inline expand because expansion ~ + (let* ((end (component-last-block (node-component call))) + (pred (block-prev end))) + (multiple-value-bind (losing-local-functional converted-lambda) + (catch 'locall-already-let-converted + (with-ir1-environment-from-node call + (let ((*lexenv* (functional-lexenv original-functional))) + (values nil + (ir1-convert-lambda + (functional-inline-expansion original-functional) + :debug-name (debug-namify + "local inline ~A" + (leaf-debug-name + original-functional))))))) + (cond (losing-local-functional + (let ((*compiler-error-context* call)) + (compiler-notify "couldn't inline expand because expansion ~ calls this LET-converted local function:~ ~% ~S" - (leaf-debug-name losing-local-functional))) - original-functional) - (t - (change-ref-leaf ref converted-lambda) - converted-lambda))) + (leaf-debug-name losing-local-functional))) + (loop for block = (block-next pred) then (block-next block) + until (eq block end) + do (setf (block-delete-p block) t)) + (loop for block = (block-next pred) then (block-next block) + until (eq block end) + do (delete-block block t)) + original-functional) + (t + (change-ref-leaf ref converted-lambda) + converted-lambda)))) original-functional)) ;;; Dispatch to the appropriate function to attempt to convert a call. diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index fd533a0..d105f77 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -639,6 +639,16 @@ (when (eq ,n-next ,n-start) (return nil)))))) +(defmacro do-nodes-carefully ((node-var cont-var block) &body body) + (with-unique-names (n-block n-last) + `(loop with ,n-block = ,block + with ,n-last = (block-last ,n-block) + for ,cont-var = (block-start ,n-block) then (node-cont ,node-var) + for ,node-var = (and ,cont-var (continuation-next ,cont-var)) + while ,node-var + do (progn ,@body) + until (eq ,node-var ,n-last)))) + ;;; Bind the IR1 context variables to the values associated with NODE, ;;; so that new, extra IR1 conversion related to NODE can be done ;;; after the original conversion pass has finished. diff --git a/tests/compiler.impure-cload.lisp b/tests/compiler.impure-cload.lisp index 2e8011f..d9905d0 100644 --- a/tests/compiler.impure-cload.lisp +++ b/tests/compiler.impure-cload.lisp @@ -52,5 +52,70 @@ (frob))))))) (delete-package :bug255) +;;; bug 148 +(defpackage :bug148 (:use :cl)) +(in-package :bug148) + +(defvar *thing*) +(defvar *zoom*) +(defstruct foo bar bletch) +(defun %zeep () + (labels ((kidify1 (kid) + ) + (kid-frob (kid) + (if *thing* + (setf sweptm + (m+ (frobnicate kid) + sweptm)) + (kidify1 kid)))) + (declare (inline kid-frob)) + (map nil + #'kid-frob + (the simple-vector (foo-bar perd))))) + +(declaim (optimize (safety 3) (speed 2) (space 1))) +(defvar *foo*) +(defvar *bar*) +(defun u-b-sra (x r ad0 &optional ad1 &rest ad-list) + (labels ((c.frob (c0) + (let () + (when *foo* + (vector-push-extend c0 *bar*)))) + (ad.frob (ad) + (if *foo* + (map nil #'ad.frob (the (vector t) *bar*)) + (dolist (b *bar*) + (c.frob b))))) + (declare (inline c.frob ad.frob)) ; 'til DYNAMIC-EXTENT + (ad.frob ad0))) + +(defun bug148-3 (ad0) + (declare (special *foo* *bar*)) + (declare (optimize (safety 3) (speed 2) (space 1))) + (labels ((c.frob ()) + (ad.frob (ad) + (if *foo* + (mapc #'ad.frob *bar*) + (dolist (b *bar*) + (c.frob))))) + (declare (inline c.frob ad.frob)) + (ad.frob ad0))) + +(defun bug148-4 (ad0) + (declare (optimize (safety 3) (speed 2) (space 1) (debug 1))) + (labels ((c.frob (x) + (* 7 x)) + (ad.frob (ad) + (loop for b in ad + collect (c.frob b)))) + (declare (inline c.frob ad.frob)) + (list (the list ad0) + (funcall (if (listp ad0) #'ad.frob #'print) ad0) + (funcall (if (listp ad0) #'ad.frob #'print) (reverse ad0))))) + +(assert (equal (eval '(bug148-4 '(1 2 3))) + '((1 2 3) (7 14 21) (21 14 7)))) + +(delete-package :bug148) (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 5bbc627..ef1b09c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.1" +"0.8.1.1"