* Fix bug 148: clean new blocks after failed inline expanding.
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
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.
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
(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"
(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
(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))
(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)
(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.
;;
(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
(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*))
;;; 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)
(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
;; 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))
(>= 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.
(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.
(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)
\f
(sb-ext:quit :unix-status 104)
;;; 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"
projects / sbcl.git / commitdiff