From c773d8256b16d86937938a396ae58ce21f567973 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 19 Aug 2008 21:48:08 -0500 Subject: [PATCH] Fix another bug; cleanup phase too eager to remove #phi nodes --- .../tree/checker/checker-tests.factor | 4 ++++ basis/compiler/tree/checker/checker.factor | 14 +++++++------- .../tree/cleanup/cleanup-tests.factor | 19 ++++++++++++++++--- basis/compiler/tree/cleanup/cleanup.factor | 7 ++++--- .../tree/combinators/combinators.factor | 5 ++++- 5 files changed, 35 insertions(+), 14 deletions(-) create mode 100644 basis/compiler/tree/checker/checker-tests.factor diff --git a/basis/compiler/tree/checker/checker-tests.factor b/basis/compiler/tree/checker/checker-tests.factor new file mode 100644 index 0000000000..5a8706b900 --- /dev/null +++ b/basis/compiler/tree/checker/checker-tests.factor @@ -0,0 +1,4 @@ +IN: compiler.tree.checker.tests +USING: compiler.tree.checker tools.test ; + +\ check-nodes must-infer diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index a862915729..58e31a8cf5 100644 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -67,6 +67,7 @@ ERROR: check-node-error node error ; SYMBOL: datastack SYMBOL: retainstack +SYMBOL: terminated? GENERIC: check-stack-flow* ( node -- ) @@ -120,11 +121,8 @@ M: #r> check-stack-flow* [ check-in-r ] [ check-out-d ] bi ; : 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 ; + check-in-d assert-datastack-empty assert-retainstack-empty ; M: #enter-recursive check-stack-flow* check-out-d ; @@ -144,7 +142,9 @@ M: #call-recursive check-stack-flow* [ "Bad terminate retain stack" throw ] unless ; M: #terminate check-stack-flow* - [ check-terminate-in-d ] [ check-terminate-in-r ] bi ; + terminated? on + [ check-terminate-in-d ] + [ check-terminate-in-r ] bi ; SYMBOL: branch-out @@ -154,7 +154,7 @@ SYMBOL: branch-out V{ } clone retainstack set (check-stack-flow) assert-retainstack-empty - datastack get + terminated? get f datastack get ? ] with-scope ; M: #branch check-stack-flow* @@ -176,7 +176,7 @@ M: #branch check-stack-flow* : set-phi-datastack ( #phi -- ) phi-in-d>> first length - branch-out get [ [ +bottom+ eq? ] all? not ] find nip + branch-out get [ ] find nip dup [ swap head* >vector ] [ 2drop V{ } clone ] if datastack set ; M: #phi check-stack-flow* diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 4d2b312e9c..9a40d3a4f6 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -4,16 +4,18 @@ math.private math generic words quotations alien alien.c-types strings sbufs sequences.private slots.private combinators definitions system layouts vectors math.partial-dispatch math.order math.functions accessors hashtables classes assocs -io.encodings.utf8 io.encodings.ascii io.encodings fry +io.encodings.utf8 io.encodings.ascii io.encodings fry slots +sorting.private compiler.tree compiler.tree.combinators compiler.tree.cleanup compiler.tree.builder compiler.tree.normalization -compiler.tree.propagation ; +compiler.tree.propagation +compiler.tree.checker ; : cleaned-up-tree ( quot -- nodes ) - build-tree normalize propagate cleanup ; + build-tree normalize propagate cleanup dup check-nodes ; [ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test @@ -430,3 +432,14 @@ cell-bits 32 = [ { integer } declare [ 0 >= ] map ] { >= fixnum>= } inlined? ] unit-test + +[ ] [ + [ + 4 pick array-capacity? + [ set-slot ] [ \ array-capacity 2nip bad-slot-value ] if + ] cleaned-up-tree drop +] unit-test + +[ ] [ + [ { merge } declare accum>> 0 >>length ] cleaned-up-tree drop +] unit-test diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor index 21a207b285..d6965cc144 100644 --- a/basis/compiler/tree/cleanup/cleanup.factor +++ b/basis/compiler/tree/cleanup/cleanup.factor @@ -124,7 +124,7 @@ M: #branch cleanup* if ; : eliminate-phi ( #phi -- node ) - dup phi-in-d>> length { + live-branches get sift length { { 0 [ drop f ] } { 1 [ eliminate-single-phi ] } [ drop ] @@ -133,8 +133,9 @@ M: #branch cleanup* M: #phi cleanup* #! Remove #phi function inputs which no longer exist. live-branches get - [ '[ , select-children sift ] change-phi-in-d ] - [ '[ , select-children sift ] change-phi-info-d ] bi + [ '[ , sift-children ] change-phi-in-d ] + [ '[ , sift-children ] change-phi-info-d ] + [ '[ , sift-children ] change-terminated ] tri eliminate-phi live-branches off ; diff --git a/basis/compiler/tree/combinators/combinators.factor b/basis/compiler/tree/combinators/combinators.factor index 37bdee7c56..0f4dc3f2a3 100644 --- a/basis/compiler/tree/combinators/combinators.factor +++ b/basis/compiler/tree/combinators/combinators.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry kernel accessors sequences sequences.deep arrays +USING: assocs fry kernel accessors sequences sequences.deep arrays stack-checker.inlining namespaces compiler.tree ; IN: compiler.tree.combinators @@ -45,6 +45,9 @@ IN: compiler.tree.combinators : select-children ( seq flags -- seq' ) [ [ drop f ] unless ] 2map ; +: sift-children ( seq flags -- seq' ) + zip [ nip ] assoc-filter keys ; + : (3each) [ 3array flip ] dip [ first3 ] prepose ; inline : 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline