From 7b384da95e6a30e1434523213aeeed3a90448c78 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Sat, 1 May 2004 11:22:38 +0000 Subject: [PATCH] 0.8.10.3: * Merge with stack-analysis-branch. --- BUGS | 12 -- NEWS | 7 ++ package-data-list.lisp-expr | 1 + src/compiler/debug.lisp | 8 ++ src/compiler/dfo.lisp | 12 ++ src/compiler/fndb.lisp | 1 + src/compiler/ir2tran.lisp | 34 +++++- src/compiler/node.lisp | 6 +- src/compiler/physenvanal.lisp | 24 ++-- src/compiler/stack.lisp | 265 +++++++++++++++++++++-------------------- src/compiler/x86/values.lisp | 29 +++++ tests/compiler.pure.lisp | 88 ++++++++++++++ version.lisp-expr | 2 +- 13 files changed, 329 insertions(+), 160 deletions(-) diff --git a/BUGS b/BUGS index 35172a6..325068d 100644 --- a/BUGS +++ b/BUGS @@ -1209,18 +1209,6 @@ WORKAROUND: successive adds of integers to double-floats produces double-floats, so none of the type restrictions in the code is violated. -298: (aka PFD MISC.183) - Compiler fails on - - (defun foo () - (multiple-value-call #'bar - (ext) - (catch 'tag (return-from foo (int))))) - - This program violates "unknown values LVAR stack discipline": if INT - returns, values returned by (EXT) must be removed from under that of - (INT). - 300: (reported by Peter Graves) Function PEEK-CHAR checks PEEK-TYPE argument type only after having read a character. This is caused with EXPLICIT-CHECK attribute in DEFKNOWN. The similar problem diff --git a/NEWS b/NEWS index f628903..fd2d442 100644 --- a/NEWS +++ b/NEWS @@ -2397,6 +2397,13 @@ changes in sbcl-0.8.10 relative to sbcl-0.8.9: ** RATIONALIZE works more according to its specification. (thanks to Bruno Haible) +changes in sbcl-0.8.11 relative to sbcl-0.8.10: + * fixed bug 313: source-transform for was erroneously + applied to a call of a value of a variable with name . + (reported by Antonio Menezes Leitao) + * on X86 fixed bug 298, revealed by Paul F. Dietz' test suite: SBCL + can remove dead unknown-values globs from the middle of the stack. + 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/package-data-list.lisp-expr b/package-data-list.lisp-expr index dae041f..af139dc 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -265,6 +265,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)" "MORE-ARG-CONTEXT" "MOVABLE" "MOVE" "MULTIPLE-CALL" "MULTIPLE-CALL-LOCAL" "MULTIPLE-CALL-NAMED" "MULTIPLE-CALL-VARIABLE" + "%%NIP-VALUES" "NLX-ENTRY" "NLX-ENTRY-MULTIPLE" "NON-DESCRIPTOR-STACK" "NOTE-ENVIRONMENT-START" "NOTE-THIS-LOCATION" "OPTIMIZER" "PACK-TRACE-TABLE" diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 92b70a5..7e6244a 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -952,6 +952,10 @@ (format t " ")) (pprint-newline :mandatory) + (awhen (block-info block) + (format t "start stack:~{ v~D~}" + (mapcar #'cont-num (ir2-block-start-stack it))) + (pprint-newline :mandatory)) (do ((ctran (block-start block) (node-next (ctran-next ctran)))) ((not ctran)) (let ((node (ctran-next ctran))) @@ -1010,6 +1014,10 @@ (cast-asserted-type node))))) (pprint-newline :mandatory))) + (awhen (block-info block) + (format t "end stack:~{ v~D~}" + (mapcar #'cont-num (ir2-block-end-stack it))) + (pprint-newline :mandatory)) (let ((succ (block-succ block))) (format t "successors~{ c~D~}~%" (mapcar (lambda (x) (cont-num (block-start x))) succ)))) diff --git a/src/compiler/dfo.lisp b/src/compiler/dfo.lisp index 195226d..3923da3 100644 --- a/src/compiler/dfo.lisp +++ b/src/compiler/dfo.lisp @@ -91,6 +91,18 @@ (setf (block-flag block) t) (dolist (succ (block-succ block)) (find-dfo-aux succ head component)) + (when (component-nlx-info-generated-p component) + ;; FIXME: We also need (and do) this walk before physenv + ;; analysis, but at that time we are probably not very + ;; interested in the actual DF order. + ;; + ;; TODO: It is probable that one of successors have the same (or + ;; similar) set of NLXes; try to shorten the walk (but think + ;; about a loop, the only exit from which is non-local). + (map-block-nlxes (lambda (nlx-info) + (let ((nle (nlx-info-target nlx-info))) + (find-dfo-aux nle head component))) + block)) (remove-from-dfo block) (add-to-dfo block head)) (values)) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index ec1de82..671ba33 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1380,6 +1380,7 @@ (defknown %nlx-entry (t) *) (defknown %%primitive (t t &rest t) *) (defknown %pop-values (t) t) +(defknown %nip-values (t t &rest t) (values)) (defknown %type-check-error (t t) nil) ;; FIXME: This function does not return, but due to the implementation diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 2d27fa2..7c4e321 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1210,16 +1210,16 @@ (defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block) (let ((ir2-physenv (physenv-info (node-physenv node)))) (move-lvar-result node block - (list (ir2-physenv-old-fp ir2-physenv) - (ir2-physenv-return-pc ir2-physenv)) - (node-lvar node)))) + (list (ir2-physenv-old-fp ir2-physenv) + (ir2-physenv-return-pc ir2-physenv)) + (node-lvar node)))) ;;;; multiple values ;;; This is almost identical to IR2-CONVERT-LET. Since LTN annotates -;;; the lvarinuation for the correct number of values (with the lvar -;;; user responsible for defaulting), we can just pick them up from -;;; the lvar. +;;; the lvar for the correct number of values (with the lvar user +;;; responsible for defaulting), we can just pick them up from the +;;; lvar. (defun ir2-convert-mv-bind (node block) (declare (type mv-combination node) (type ir2-block block)) (let* ((lvar (first (basic-combination-args node))) @@ -1282,6 +1282,28 @@ (vop reset-stack-pointer node block (first (ir2-lvar-locs 2lvar))))) +(defoptimizer (%nip-values ir2-convert) ((last-nipped last-preserved &rest moved) + node block) + #!-x86 + (bug "%NIP-VALUES is not implemented on this platform.") + #!+x86 + (let ((2after (lvar-info (lvar-value last-nipped))) + ; pointer immediately after the nipped block + (2first (lvar-info (lvar-value last-preserved))) + ; pointer to the first nipped word + (moved-tns (loop for lvar-ref in moved + for lvar = (lvar-value lvar-ref) + for 2lvar = (lvar-info lvar) + ;when 2lvar + collect (first (ir2-lvar-locs 2lvar))))) + (aver (eq (ir2-lvar-kind 2after) :unknown)) + (aver (eq (ir2-lvar-kind 2first) :unknown)) + (vop* %%nip-values node block + ((first (ir2-lvar-locs 2after)) + (first (ir2-lvar-locs 2first)) + (reference-tn-list moved-tns nil)) + ((reference-tn-list moved-tns t))))) + ;;; Deliver the values TNs to LVAR using MOVE-LVAR-RESULT. (defoptimizer (values ir2-convert) ((&rest values) node block) (let ((tns (mapcar (lambda (x) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 701d86e..a07551f 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -373,7 +373,8 @@ ;; inline expansion. Unlike NEW-FUNCTIONALS, this is not disjoint ;; from COMPONENT-LAMBDAS. (reanalyze-functionals nil :type list) - (delete-blocks nil :type list)) + (delete-blocks nil :type list) + (nlx-info-generated-p nil :type boolean)) (defprinter (component :identity t) name #!+sb-show id @@ -1274,7 +1275,8 @@ ;;; continuation and the exit continuation's DEST. Instead of using ;;; the returned value being delivered directly to the exit ;;; continuation, it is delivered to our VALUE lvar. The original exit -;;; lvar is the exit node's LVAR. +;;; lvar is the exit node's LVAR; physenv analysis also makes it the +;;; lvar of %NLX-ENTRY call. (defstruct (exit (:include valued-node) (:copier nil)) ;; the ENTRY node that this is an exit for. If null, this is a diff --git a/src/compiler/physenvanal.lisp b/src/compiler/physenvanal.lisp index cf43865..022442e 100644 --- a/src/compiler/physenvanal.lisp +++ b/src/compiler/physenvanal.lisp @@ -50,6 +50,7 @@ (setf (functional-kind fun) nil) (delete-functional fun))))) + (setf (component-nlx-info-generated-p component) t) (values)) ;;; This is to be called on a COMPONENT with top level LAMBDAs before @@ -232,8 +233,8 @@ ;;; knows what entry is being done. ;;; ;;; The link from the EXIT block to the entry stub is changed to be a -;;; link to the component head. Similarly, the EXIT block is linked to -;;; the component tail. This leaves the entry stub reachable, but +;;; link from the component head. Similarly, the EXIT block is linked +;;; to the component tail. This leaves the entry stub reachable, but ;;; makes the flow graph less confusing to flow analysis. ;;; ;;; If a CATCH or an UNWIND-protect, then we set the LEXENV for the @@ -280,9 +281,10 @@ ;;; function reference. This will cause the escape function to ;;; be deleted (although not removed from the DFO.) The escape ;;; function is no longer needed, and we don't want to emit code -;;; for it. We then also change the %NLX-ENTRY call to use the -;;; NLX continuation so that there will be a use to represent -;;; the NLX use. +;;; for it. +;;; -- Change the %NLX-ENTRY call to use the NLX lvar so that 1) there +;;; will be a use to represent the NLX use; 2) make life easier for +;;; the stack analysis. (defun note-non-local-exit (env exit) (declare (type physenv env) (type exit exit)) (let ((lvar (node-lvar exit)) @@ -300,11 +302,13 @@ (mapc (lambda (x) (setf (node-derived-type x) *wild-type*)) (leaf-refs exit-fun)) - (substitute-leaf (find-constant info) exit-fun) - (let ((node (block-last (nlx-info-target info)))) - (delete-lvar-use node) - (aver (eq lvar (node-lvar exit))) - (add-lvar-use node lvar))))) + (substitute-leaf (find-constant info) exit-fun)) + (when lvar + (let ((node (block-last (nlx-info-target info)))) + (unless (node-lvar node) + (aver (eq lvar (node-lvar exit))) + (setf (node-derived-type node) (lvar-derived-type lvar)) + (add-lvar-use node lvar)))))) (values)) ;;; Iterate over the EXITs in COMPONENT, calling NOTE-NON-LOCAL-EXIT diff --git a/src/compiler/stack.lisp b/src/compiler/stack.lisp index 65b51e6..83ce8f9 100644 --- a/src/compiler/stack.lisp +++ b/src/compiler/stack.lisp @@ -1,7 +1,7 @@ ;;;; This file implements the stack analysis phase in the compiler. We ;;;; do a graph walk to determine which unknown-values lvars are on ;;;; the stack at each point in the program, and then we insert -;;;; cleanup code to pop off unused values. +;;;; cleanup code to remove unused values. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -41,129 +41,129 @@ (setf (ir2-block-pushed 2block) (pushed)))) (values)) -;;;; annotation graph walk +;;;; Computation of live UVL sets +(defun nle-block-nlx-info (block) + (let* ((start-node (block-start-node block)) + (nlx-ref (ctran-next (node-next start-node))) + (nlx-info (constant-value (ref-leaf nlx-ref)))) + nlx-info)) +(defun nle-block-entry-block (block) + (let* ((nlx-info (nle-block-nlx-info block)) + (mess-up (cleanup-mess-up (nlx-info-cleanup nlx-info))) + (entry-block (node-block mess-up))) + entry-block)) ;;; Add LVARs from LATE to EARLY; use EQ to check whether EARLY has ;;; been changed. -(defun merge-stacks (early late) +(defun merge-uvl-live-sets (early late) (declare (type list early late)) - (cond ((null early) late) - ((null late) early) - ((tailp early late) late) - ((tailp late early) early) - ;; FIXME - (t (bug "Lexical unwinding of UVL stack is not implemented.")))) + (dolist (e late early) + (pushnew e early))) ;;; Update information on stacks of unknown-values LVARs on the ;;; boundaries of BLOCK. Return true if the start stack has been ;;; changed. -(defun stack-update (block) +;;; +;;; An LVAR is live at the end iff it is live at some of blocks, which +;;; BLOCK can transfer control to. There are two kind of control +;;; transfers: normal, expressed with BLOCK-SUCC, and NLX. +(defun update-uvl-live-sets (block) (declare (type cblock block)) - (declare (optimize (debug 3))) (let* ((2block (block-info block)) + (original-start (ir2-block-start-stack 2block)) (end (ir2-block-end-stack 2block)) - (new-end end) - (cleanup (block-end-cleanup block)) - (found-similar-p nil)) - (declare (ignore #-nil cleanup)) + (new-end end)) (dolist (succ (block-succ block)) - #+nil - (when (and (< block succ) - (eq cleanup (block-end-cleanup succ))) - (setq found-similar-p t)) - (setq new-end (merge-stacks new-end (ir2-block-start-stack (block-info succ))))) - (unless found-similar-p - (map-block-nlxes (lambda (nlx-info) - (let* ((nle (nlx-info-target nlx-info)) - (nle-start-stack (ir2-block-start-stack - (block-info nle))) - (exit-lvar (nlx-info-lvar nlx-info))) - (when (eq exit-lvar (car nle-start-stack)) - (pop nle-start-stack)) - (setq new-end (merge-stacks new-end - nle-start-stack)))) - block)) + (setq new-end (merge-uvl-live-sets new-end + (ir2-block-start-stack (block-info succ))))) + (map-block-nlxes (lambda (nlx-info) + (let* ((nle (nlx-info-target nlx-info)) + (nle-start-stack (ir2-block-start-stack + (block-info nle))) + (exit-lvar (nlx-info-lvar nlx-info)) + (next-stack (if exit-lvar + (remove exit-lvar nle-start-stack) + nle-start-stack))) + (setq new-end (merge-uvl-live-sets + new-end next-stack)))) + block) (setf (ir2-block-end-stack 2block) new-end) + (let ((start new-end)) - (dolist (push (reverse (ir2-block-pushed 2block))) - (if (eq (car start) push) - (pop start) - (aver (not (member push start))))) + (setq start (set-difference start (ir2-block-pushed 2block))) + (setq start (merge-uvl-live-sets start (ir2-block-popped 2block))) - (dolist (pop (reverse (ir2-block-popped 2block))) - (push pop start)) + ;; We cannot delete unused UVLs during NLX, so all UVLs live at + ;; ENTRY will be actually live at NLE. + (when (and (eq (component-head (block-component block)) + (first (block-pred block))) + (not (bind-p (block-start-node block)))) + (let* ((entry-block (nle-block-entry-block block)) + (entry-stack (ir2-block-start-stack (block-info entry-block)))) + (setq start (merge-uvl-live-sets start entry-stack)))) - (cond ((equal-but-no-car-recursion start - (ir2-block-start-stack 2block)) + (when *check-consistency* + (aver (subsetp original-start start))) + (cond ((subsetp start original-start) nil) (t (setf (ir2-block-start-stack 2block) start) t))))) -;;; Do stack annotation for any values generators in Block that were -;;; unreached by all walks (i.e. the lvar isn't live at the point that -;;; it is generated.) This will only happen when the values receiver cannot be -;;; reached from this particular generator (due to an unconditional control -;;; transfer.) -;;; -;;; What we do is push on the End-Stack all lvars in Pushed that -;;; aren't already present in the End-Stack. When we find any pushed -;;; lvar that isn't live, it must be the case that all lvars -;;; pushed after (on top of) it aren't live. -;;; -;;; If we see a pushed lvar that is the LVAR of a tail call, then we -;;; ignore it, since the tail call didn't actually push anything. The -;;; tail call must always the last in the block. -;;; -;;; [This function also fixes End-Stack in NLEs.] -(defun annotate-dead-values (block) - (declare (type cblock block)) + +;;;; Ordering of live UVL stacks + +;;; Put UVLs on the start/end stacks of BLOCK in the right order. PRED +;;; is a predecessor of BLOCK with already sorted stacks; because all +;;; UVLs being live at the BLOCK start are live in PRED, we just need +;;; to delete dead UVLs. +(defun order-block-uvl-sets (block pred) (let* ((2block (block-info block)) - (stack (ir2-block-end-stack 2block)) - (last (block-last block)) - (tailp-lvar (if (node-tail-p last) (node-lvar last)))) - (do ((pushes (ir2-block-pushed 2block) (rest pushes)) - (popping nil)) - ((null pushes)) - (let ((push (first pushes))) - (cond ((member push stack) - (aver (not popping))) - ((eq push tailp-lvar) - (aver (null (rest pushes)))) - (t - (push push (ir2-block-end-stack 2block)) - (setq popping t)))))) + (pred-end-stack (ir2-block-end-stack (block-info pred))) + (start (ir2-block-start-stack 2block)) + (start-stack (loop for lvar in pred-end-stack + when (memq lvar start) + collect lvar)) + (end (ir2-block-end-stack 2block))) + (when *check-consistency* + (aver (subsetp start start-stack))) + (setf (ir2-block-start-stack 2block) start-stack) - (values)) + (let* ((last (block-last block)) + (tailp-lvar (if (node-tail-p last) (node-lvar last))) + (end-stack start-stack)) + (dolist (pop (ir2-block-popped 2block)) + (aver (eq pop (car end-stack))) + (pop end-stack)) + (dolist (push (ir2-block-pushed 2block)) + (aver (not (memq push end-stack))) + (push push end-stack)) + (aver (subsetp end end-stack)) + (when (and tailp-lvar + (eq (ir2-lvar-kind (lvar-info tailp-lvar)) :unknown)) + (aver (eq tailp-lvar (first end-stack))) + (pop end-stack)) + (setf (ir2-block-end-stack 2block) end-stack)))) -;;; For every NLE block push all LVARs that are live in its ENTRY to -;;; its start stack. (We cannot pop unused LVARs on a control transfer -;;; to an NLE block, so we must do it later.) -(defun fix-nle-block-stacks (component) - (declare (type component component)) - (dolist (block (block-succ (component-head component))) - (let ((start-node (block-start-node block))) - (unless (bind-p start-node) - (let* ((2block (block-info block)) - (start-stack (block-start-stack 2block)) - (nlx-ref (ctran-next (node-next start-node))) - (nlx-info (constant-value (ref-leaf nlx-ref))) - (mess-up (cleanup-mess-up (nlx-info-cleanup nlx-info))) - (entry-block (node-block mess-up)) - (entry-stack (ir2-block-start-stack (block-info entry-block))) - (exit-lvar (nlx-info-lvar nlx-info))) - (when (and exit-lvar - (eq exit-lvar (car start-stack))) - (when *check-consistency* - (aver (not (memq exit-lvar entry-stack)))) - (push exit-lvar entry-stack)) - (when *check-consistency* - (aver (subsetp start-stack entry-stack))) - (setf (ir2-block-start-stack 2block) entry-stack) - (setf (ir2-block-end-stack 2block) entry-stack) - ; ANNOTATE-DEAD-VALUES will do the rest - ))))) +(defun order-uvl-sets (component) + (clear-flags component) + (loop with head = (component-head component) + with repeat-p do + (setq repeat-p nil) + (do-blocks (block component) + (unless (block-flag block) + (let ((pred (find-if #'block-flag (block-pred block)))) + (when (and (eq pred head) + (not (bind-p (block-start-node block)))) + (let ((entry (nle-block-entry-block block))) + (setq pred (if (block-flag entry) entry nil)))) + (cond (pred + (setf (block-flag block) t) + (order-block-uvl-sets block pred)) + (t + (setq repeat-p t)))))) + while repeat-p)) ;;; This is called when we discover that the stack-top unknown-values ;;; lvar at the end of BLOCK1 is different from that at the start of @@ -183,20 +183,38 @@ (defun discard-unused-values (block1 block2) (declare (type cblock block1 block2)) (let* ((block1-stack (ir2-block-end-stack (block-info block1))) - (block2-stack (ir2-block-start-stack (block-info block2))) - (last-popped (elt block1-stack - (- (length block1-stack) - (length block2-stack) - 1)))) - (aver (tailp block2-stack block1-stack)) - - (let* ((block (insert-cleanup-code block1 block2 - (block-start-node block2) - `(%pop-values ',last-popped))) - (2block (make-ir2-block block))) - (setf (block-info block) 2block) - (add-to-emit-order 2block (block-info block1)) - (ltn-analyze-belated-block block))) + (block2-stack (ir2-block-start-stack (block-info block2))) + (cleanup-code + (cond ((eq (car block1-stack) (car block2-stack)) + (binding* ((preserved-count (mismatch block1-stack block2-stack) + :exit-if-null) + (n-last-preserved (1- preserved-count)) + (nipped-count (- (length block1-stack) + (length block2-stack))) + (n-last-nipped (+ n-last-preserved nipped-count))) + (aver (equal (nthcdr (1+ n-last-nipped) block1-stack) + (nthcdr preserved-count block2-stack))) + (compiler-notify "%NIP-VALUES emitted") + `(%nip-values ',(elt block1-stack n-last-nipped) + ',(elt block1-stack n-last-preserved) + ,@(loop for moved in block1-stack + repeat preserved-count + collect `',moved)))) + (t + (let* ((n-popped (- (length block1-stack) + (length block2-stack))) + (last-popped (elt block1-stack (1- n-popped)))) + (when *check-consistency* + (aver (equal block2-stack (nthcdr n-popped block1-stack)))) + `(%pop-values ',last-popped)))))) + (when cleanup-code + (let* ((block (insert-cleanup-code block1 block2 + (block-start-node block2) + cleanup-code)) + (2block (make-ir2-block block))) + (setf (block-info block) 2block) + (add-to-emit-order 2block (block-info block1)) + (ltn-analyze-belated-block block)))) (values)) @@ -220,12 +238,6 @@ ;;; received. This phase doesn't need to be run when Values-Receivers ;;; is null, i.e. there are no unknown-values lvars used across block ;;; boundaries. -;;; -;;; Do the backward graph walk, starting at each values receiver. We -;;; ignore receivers that already have a non-null START-STACK. These -;;; are nested values receivers that have already been reached on -;;; another walk. We don't want to clobber that result with our null -;;; initial stack. (defun stack-analyze (component) (declare (type component component)) (let* ((2comp (component-info component)) @@ -235,25 +247,20 @@ (dolist (block generators) (find-pushed-lvars block)) + ;;; Compute sets of live UVLs (loop for did-something = nil do (do-blocks-backwards (block component) - (when (stack-update block) + (when (update-uvl-live-sets block) (setq did-something t))) while did-something) - (when *check-consistency* - (dolist (block (block-succ (component-head component))) - (when (bind-p (block-start-node block)) - (aver (null (ir2-block-start-stack (block-info block))))))) - - (dolist (block generators) - (annotate-dead-values block)) + (order-uvl-sets component) (do-blocks (block component) - (let ((top (car (ir2-block-end-stack (block-info block))))) + (let ((top (ir2-block-end-stack (block-info block)))) (dolist (succ (block-succ block)) (when (and (block-start succ) - (not (eq (car (ir2-block-start-stack (block-info succ))) + (not (eq (ir2-block-start-stack (block-info succ)) top))) (discard-unused-values block succ)))))) diff --git a/src/compiler/x86/values.lisp b/src/compiler/x86/values.lisp index 55cbe21..9e5a4c1 100644 --- a/src/compiler/x86/values.lisp +++ b/src/compiler/x86/values.lisp @@ -16,6 +16,35 @@ (:generator 1 (move esp-tn ptr))) +(define-vop (%%nip-values) + (:args (last-nipped-ptr :scs (any-reg) :target edi) + (last-preserved-ptr :scs (any-reg) :target esi) + (moved-ptrs :scs (any-reg) :more t)) + (:results (r-moved-ptrs :scs (any-reg) :more t) + ;; same as MOVED-PTRS + ) + (:temporary (:sc any-reg :offset esi-offset) esi) + (:temporary (:sc any-reg :offset edi-offset) edi) + (:ignore r-moved-ptrs) + (:generator 1 + (move edi last-nipped-ptr) + (move esi last-preserved-ptr) + (inst sub esi n-word-bytes) + (inst sub edi n-word-bytes) + (inst cmp esp-tn esi) + (inst jmp :a done) + (inst std) + LOOP + (inst movs :dword) + (inst cmp esp-tn esi) + (inst jmp :be loop) + DONE + (inst lea esp-tn (make-ea :dword :base edi :disp n-word-bytes)) + (inst sub edi esi) + (loop for moved = moved-ptrs then (tn-ref-across moved) + while moved + do (inst add (tn-ref-tn moved) edi)))) + ;;; Push some values onto the stack, returning the start and number of values ;;; pushed as results. It is assumed that the Vals are wired to the standard ;;; argument locations. Nvals is the number of values to push. diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 4413058..56811da 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1033,6 +1033,8 @@ 215067723) 13739018)) + +;;;; Bugs in stack analysis ;;; bug 299 (reported by PFD) (assert (equal (funcall @@ -1044,6 +1046,43 @@ (if (eval t) (eval '(values :a :b :c)) nil) (catch 'foo (throw 'foo (values :x :y))))))) '(:a :b :c :x :y))) +;;; bug 298 (= MISC.183) +(assert (zerop (funcall + (compile + nil + '(lambda (a b c) + (declare (type (integer -368154 377964) a)) + (declare (type (integer 5044 14959) b)) + (declare (type (integer -184859815 -8066427) c)) + (declare (ignorable a b c)) + (declare (optimize (speed 3))) + (declare (optimize (safety 1))) + (declare (optimize (debug 1))) + (block b7 + (flet ((%f3 (f3-1 f3-2 f3-3) 0)) + (apply #'%f3 0 (catch 'foo (return-from b7 (%f3 0 b c))) c nil))))) + 0 6000 -9000000))) +(assert (equal (eval '(let () (apply #'list 1 (list (catch 'a (throw 'a (block b 2))))))) + '(1 2))) +(let ((f (compile + nil + '(lambda (x) + (block foo + (multiple-value-call #'list + :a + (block bar + (return-from foo + (multiple-value-call #'list + :b + (block quux + (return-from bar + (catch 'baz + (if x + (return-from quux 1) + (throw 'baz 2)))))))))))))) + (assert (equal (funcall f t) '(:b 1))) + (assert (equal (funcall f nil) '(:a 2)))) + ;;; MISC.185 (assert (equal (funcall @@ -1094,6 +1133,55 @@ :good (values result1 result2)))) :good)) + +;;; MISC.290 +(assert (zerop + (funcall + (compile + nil + '(lambda () + (declare + (optimize (speed 3) (space 3) (safety 1) + (debug 2) (compilation-speed 0))) + (apply (constantly 0) (catch 'ct2 0) 0 (catch 'ct2 0) nil)))))) + +;;; MISC.292 +(assert (zerop (funcall + (compile + nil + '(lambda (a b) + (declare (optimize (speed 2) (space 0) (safety 3) (debug 1) + (compilation-speed 2))) + (apply (constantly 0) + a + 0 + (catch 'ct6 + (apply (constantly 0) + 0 + 0 + (let* ((v1 + (let ((*s7* 0)) + b))) + 0) + 0 + nil)) + 0 + nil))) + 1 2))) + +;;; misc.295 +(assert (eql + (funcall + (compile + nil + '(lambda () + (declare (optimize (speed 1) (space 0) (safety 0) (debug 0))) + (multiple-value-prog1 + (the integer (catch 'ct8 (catch 'ct7 15867134))) + (catch 'ct1 (throw 'ct1 0)))))) + 15867134)) + + ;;; MISC.275 (assert (zerop diff --git a/version.lisp-expr b/version.lisp-expr index 926a8ac..5e1b426 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.10.2" +"0.8.10.3" -- 1.7.10.4