From 17758f37493f4bf6683e18f036be487407e0046e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 19 Aug 2008 17:11:33 -0500 Subject: [PATCH] Stack flow checker; various fixes --- basis/compiler/generator/generator.factor | 2 +- basis/compiler/tree/checker/checker.factor | 145 +++++++++++++++++- basis/compiler/tree/cleanup/cleanup.factor | 12 +- .../tree/dead-code/dead-code-tests.factor | 8 +- .../escape-analysis-tests.factor | 5 + .../tree/normalization/normalization.factor | 56 ++++++- basis/stack-checker/branches/branches.factor | 5 +- 7 files changed, 218 insertions(+), 15 deletions(-) diff --git a/basis/compiler/generator/generator.factor b/basis/compiler/generator/generator.factor index 35ad0656cd..4d826c40d2 100755 --- a/basis/compiler/generator/generator.factor +++ b/basis/compiler/generator/generator.factor @@ -92,7 +92,7 @@ M: node generate-node drop iterate-next ; %jump-label ; : generate-call ( label -- next ) - dup maybe-compile + ! dup maybe-compile end-basic-block dup compiling-loops get at [ %jump-label f diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index 0900d2ded9..a862915729 100644 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -1,13 +1,15 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: sequences kernel sets namespaces accessors assocs -arrays combinators continuations columns math +arrays combinators continuations columns math vectors +stack-checker.branches compiler.tree compiler.tree.def-use compiler.tree.combinators ; IN: compiler.tree.checker -! Check some invariants. +! Check some invariants; this can help catch compiler bugs. + ERROR: check-use-error value message ; : check-use ( value uses -- ) @@ -63,7 +65,144 @@ ERROR: check-node-error node error ; tri ] [ check-node-error ] recover ; +SYMBOL: datastack +SYMBOL: retainstack + +GENERIC: check-stack-flow* ( node -- ) + +: (check-stack-flow) ( nodes -- ) + [ check-stack-flow* ] each ; + +: init-stack-flow ( -- ) + V{ } clone datastack set + V{ } clone retainstack set ; + +: check-stack-flow ( nodes -- ) + [ + init-stack-flow + (check-stack-flow) + ] with-scope ; + +: check-inputs ( seq var -- ) + [ dup length ] dip [ swap cut* swap ] change + sequence= [ "Bad stack flow" throw ] unless ; + +: check-in-d ( node -- ) + in-d>> datastack check-inputs ; + +: check-in-r ( node -- ) + in-r>> retainstack check-inputs ; + +: check-outputs ( node var -- ) + get push-all ; + +: check-out-d ( node -- ) + out-d>> datastack check-outputs ; + +: check-out-r ( node -- ) + out-r>> retainstack check-outputs ; + +M: #introduce check-stack-flow* check-out-d ; + +M: #push check-stack-flow* check-out-d ; + +M: #call check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; + +M: #shuffle check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; + +M: #>r check-stack-flow* [ check-in-d ] [ check-out-r ] bi ; + +M: #r> check-stack-flow* [ check-in-r ] [ check-out-d ] bi ; + +: assert-datastack-empty ( -- ) + datastack get empty? [ "Data stack not empty" throw ] unless ; + +: assert-retainstack-empty ( -- ) + retainstack get empty? [ "Retain stack not empty" throw ] unless ; + +: must-consume-all ( -- ) + assert-datastack-empty assert-retainstack-empty ; + +M: #return check-stack-flow* + check-in-d must-consume-all ; + +M: #enter-recursive check-stack-flow* + check-out-d ; + +M: #return-recursive check-stack-flow* + [ check-in-d ] [ check-out-d ] bi ; + +M: #call-recursive check-stack-flow* + [ check-in-d ] [ check-out-d ] bi ; + +: check-terminate-in-d ( #terminate -- ) + in-d>> datastack get over length tail* sequence= + [ "Bad terminate data stack" throw ] unless ; + +: check-terminate-in-r ( #terminate -- ) + in-r>> retainstack get over length tail* sequence= + [ "Bad terminate retain stack" throw ] unless ; + +M: #terminate check-stack-flow* + [ check-terminate-in-d ] [ check-terminate-in-r ] bi ; + +SYMBOL: branch-out + +: check-branch ( nodes -- stack ) + [ + datastack [ clone ] change + V{ } clone retainstack set + (check-stack-flow) + assert-retainstack-empty + datastack get + ] with-scope ; + +M: #branch check-stack-flow* + [ check-in-d ] + [ children>> [ check-branch ] map branch-out set ] + bi ; + +: check-phi-in ( #phi -- ) + phi-in-d>> branch-out get [ + over [ +bottom+ eq? ] all? [ + 2drop + ] [ + over length tail* sequence= [ + "Branch outputs don't match phi inputs" + throw + ] unless + ] if + ] 2each ; + +: set-phi-datastack ( #phi -- ) + phi-in-d>> first length + branch-out get [ [ +bottom+ eq? ] all? not ] find nip + dup [ swap head* >vector ] [ 2drop V{ } clone ] if datastack set ; + +M: #phi check-stack-flow* + [ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri ; + +M: #recursive check-stack-flow* + [ + init-stack-flow + child>> (check-stack-flow) + datastack get + ] with-scope + datastack set ; + +M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; + +M: #alien-invoke check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; + +M: #alien-indirect check-stack-flow* [ check-in-d ] [ check-out-d ] bi ; + +M: #alien-callback check-stack-flow* drop ; + +M: #declare check-stack-flow* drop ; + : check-nodes ( nodes -- ) compute-def-use check-def-use - [ check-node ] each-node ; + [ [ check-node ] each-node ] + [ check-stack-flow ] + bi ; diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index ff42a08818..21a207b285 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -3,6 +3,7 @@ USING: kernel accessors sequences sequences.deep combinators fry classes.algebra namespaces assocs math math.private math.partial-dispatch classes.tuple classes.tuple.private +stack-checker.branches compiler.tree compiler.tree.intrinsics compiler.tree.combinators @@ -13,8 +14,7 @@ IN: compiler.tree.cleanup ! A phase run after propagation to finish the job, so to speak. ! Codifies speculative inlining decisions, deletes branches ! marked as never taken, and flattens local recursive blocks -! that do not call themselves. Finally, if inlining inserts a -! #terminate, we delete all nodes after that. +! that do not call themselves. GENERIC: delete-node ( node -- ) @@ -117,10 +117,16 @@ M: #branch cleanup* [ live-branches>> live-branches set ] } cleave ; +: eliminate-single-phi ( #phi -- node ) + [ phi-in-d>> first ] [ out-d>> ] bi over [ +bottom+ eq? ] all? + [ [ drop ] [ [ f swap #push ] map ] bi* ] + [ #copy ] + if ; + : eliminate-phi ( #phi -- node ) dup phi-in-d>> length { { 0 [ drop f ] } - { 1 [ [ phi-in-d>> first ] [ out-d>> ] bi #copy ] } + { 1 [ eliminate-single-phi ] } [ drop ] } case ; diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor index 8804a9417e..5e2eb2c38d 100644 --- a/basis/compiler/tree/dead-code/dead-code-tests.factor +++ b/basis/compiler/tree/dead-code/dead-code-tests.factor @@ -89,7 +89,7 @@ IN: compiler.tree.dead-code.tests : non-flushable-3 ( a b -- c ) 2drop f ; -[ [ [ drop drop ] [ non-flushable-3 drop ] if ] ] [ +[ [ [ 2drop ] [ non-flushable-3 drop ] if ] ] [ [ [ flushable-1 ] [ non-flushable-3 ] if drop ] optimize-quot ] unit-test @@ -100,3 +100,9 @@ IN: compiler.tree.dead-code.tests [ [ [ . ] [ drop ] if ] ] [ [ [ dup . ] [ ] if drop ] optimize-quot ] unit-test [ [ f ] ] [ [ f dup [ ] [ ] if ] optimize-quot ] unit-test + +[ ] [ [ over [ ] [ dup [ "X" throw ] [ "X" throw ] if ] if ] optimize-quot drop ] unit-test + +: boo ( a b -- c ) 2drop f ; + +[ [ dup 4 eq? [ nip ] [ boo ] if ] ] [ [ dup dup 4 eq? [ drop nip ] [ drop boo ] if ] optimize-quot ] unit-test diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index 7b0f03e13d..9e44e9fc11 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -305,3 +305,8 @@ C: ro-box [ bleach-node ] curry [ ] compose impeach-node ; inline recursive [ 2 ] [ [ [ ] bleach-node ] count-unboxed-allocations ] unit-test + +[ 0 ] [ + [ dup -1 over >= [ 0 >= [ "A" throw ] unless ] [ drop ] if ] + count-unboxed-allocations +] unit-test diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor index ddb566709a..a43179653f 100644 --- a/basis/compiler/tree/normalization/normalization.factor +++ b/basis/compiler/tree/normalization/normalization.factor @@ -74,6 +74,46 @@ M: #recursive collect-label-info M: node collect-label-info drop ; +! Rename +SYMBOL: rename-map + +: rename-value ( value -- value' ) + [ rename-map get at ] keep or ; + +: rename-values ( values -- values' ) + [ rename-value ] map ; + +GENERIC: rename-node-values* ( node -- node ) + +M: #introduce rename-node-values* ; + +M: #shuffle rename-node-values* + [ rename-values ] change-in-d + [ [ rename-value ] assoc-map ] change-mapping ; + +M: #push rename-node-values* ; + +M: #r> rename-node-values* + [ rename-values ] change-in-r ; + +M: #terminate rename-node-values* + [ rename-values ] change-in-d + [ rename-values ] change-in-r ; + +M: #phi rename-node-values* + [ [ rename-values ] map ] change-phi-in-d ; + +M: #declare rename-node-values* + [ [ [ rename-value ] dip ] assoc-map ] change-declaration ; + +M: #alien-callback rename-node-values* ; + +M: node rename-node-values* + [ rename-values ] change-in-d ; + +: rename-node-values ( nodes -- nodes' ) + dup [ rename-node-values* drop ] each-node ; + ! Normalize GENERIC: normalize* ( node -- node' ) @@ -85,8 +125,11 @@ SYMBOL: introduction-stack : pop-introductions ( n -- values ) introduction-stack [ swap cut* swap ] change ; +: add-renamings ( old new -- ) + rename-map get '[ , set-at ] 2each ; + M: #introduce normalize* - out-d>> [ length pop-introductions ] keep #copy ; + out-d>> [ length pop-introductions ] keep add-renamings f ; SYMBOL: remaining-introductions @@ -142,10 +185,10 @@ M: #enter-recursive normalize* bi* ] [ introduction-stack [ prepend ] change ] bi ; -: call>return ( #call-recursive n -- nodes ) - [ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ , head ] ] bi* bi@ #copy ] +: call>return ( #call-recursive n -- #call-recursive ) + [ [ [ in-d>> ] [ out-d>> ] bi ] [ '[ , head ] ] bi* bi@ add-renamings ] [ '[ , tail ] [ change-in-d ] [ change-out-d ] bi ] - 2bi 2array ; + 2bi ; M: #call-recursive normalize* dup unchanged-underneath { @@ -157,7 +200,8 @@ M: #call-recursive normalize* M: node normalize* ; : normalize ( nodes -- nodes' ) + H{ } clone rename-map set dup [ collect-label-info ] each-node dup count-introductions make-values - [ (normalize) ] [ nip #introduce ] 2bi - prefix ; + [ (normalize) ] [ nip #introduce ] 2bi prefix + rename-node-values ; diff --git a/basis/stack-checker/branches/branches.factor b/basis/stack-checker/branches/branches.factor index aec6fc59cf..015e00ef46 100644 --- a/basis/stack-checker/branches/branches.factor +++ b/basis/stack-checker/branches/branches.factor @@ -64,10 +64,13 @@ SYMBOL: quotations : terminated-phi ( seq -- terminated ) terminated? branch-variable ; +: terminate-branches ( seq -- ) + [ terminated? swap at ] all? [ terminate ] when ; + : compute-phi-function ( seq -- ) [ quotation active-variable sift quotations set ] [ [ datastack-phi ] [ terminated-phi ] bi #phi, ] - [ [ terminated? swap at ] all? terminated? set ] + [ terminate-branches ] tri ; : copy-inference ( -- )