From 97871d40639e23941cd363b89d003331a7f1c607 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Aug 2008 20:04:36 -0500 Subject: [PATCH] Fix problem with terminating branches; normalize always pushes #introduce to the front --- .../tree/combinators/combinators.factor | 8 ++- .../tree/normalization/normalization.factor | 51 ++++++++++++------- unfinished/compiler/tree/tree.factor | 5 +- .../stack-checker/branches/branches.factor | 10 +++- .../stack-checker/visitor/dummy/dummy.factor | 2 +- .../stack-checker/visitor/visitor.factor | 2 +- 6 files changed, 55 insertions(+), 23 deletions(-) diff --git a/unfinished/compiler/tree/combinators/combinators.factor b/unfinished/compiler/tree/combinators/combinators.factor index d3009daf80..3adce27b43 100644 --- a/unfinished/compiler/tree/combinators/combinators.factor +++ b/unfinished/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 +USING: fry kernel accessors sequences sequences.deep arrays compiler.tree ; IN: compiler.tree.combinators @@ -44,3 +44,9 @@ IN: compiler.tree.combinators : select-children ( seq flags -- seq' ) [ [ drop f ] unless ] 2map ; + +: (3each) [ 3array flip ] dip [ first3 ] prepose ; inline + +: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline + +: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline diff --git a/unfinished/compiler/tree/normalization/normalization.factor b/unfinished/compiler/tree/normalization/normalization.factor index 72ea885967..b6a9f126d6 100644 --- a/unfinished/compiler/tree/normalization/normalization.factor +++ b/unfinished/compiler/tree/normalization/normalization.factor @@ -9,8 +9,9 @@ IN: compiler.tree.normalization ! fix up some oddities in the tree output by the stack checker: ! ! - We rewrite the code is that #introduce nodes only appear -! at the top level, and not inside #recursive. This enables more -! accurate type inference for 'row polymorphic' combinators. +! at the beginning of a program, never having #introduce follow +! any other type of node or appear inside a #branch or +! #recursive. This simplifies some types of analysis. ! ! - We collect #return-recursive and #call-recursive nodes and ! store them in the #recursive's label slot. @@ -46,6 +47,10 @@ M: #branch count-introductions* [ count-introductions ] map supremum introductions [ + ] change ; +M: #recursive count-introductions* + [ label>> ] [ child>> count-introductions ] bi + >>introductions drop ; + M: node count-introductions* drop ; ! Collect label info @@ -58,18 +63,16 @@ M: #call-recursive collect-label-info dup label>> calls>> push ; M: #recursive collect-label-info - [ label>> V{ } clone >>calls ] - [ child>> count-introductions ] - bi >>introductions drop ; + label>> V{ } clone >>calls drop ; M: node collect-label-info drop ; ! Eliminate introductions SYMBOL: introduction-stack -: fixup-enter-recursive ( recursive -- ) +: fixup-enter-recursive ( introductions recursive -- ) [ child>> first ] [ in-d>> ] bi >>in-d - [ introduction-stack get prepend ] change-out-d + [ append ] change-out-d drop ; GENERIC: eliminate-introductions* ( node -- node' ) @@ -93,23 +96,37 @@ M: #branch eliminate-introductions* [ [ length ] map infimum introduction-stack [ swap head ] change ] bi ; +: eliminate-phi-introductions ( introductions seq terminated -- seq' ) + [ flip ] dip [ [ nip ] [ over length tail append ] if ] 3map flip ; + M: #phi eliminate-introductions* - remaining-introductions get swap - [ flip [ over length tail append ] 2map flip ] change-phi-in-d ; + remaining-introductions get swap dup terminated>> + '[ , eliminate-phi-introductions ] change-phi-in-d ; M: node eliminate-introductions* ; -: eliminate-introductions ( recursive n -- ) - make-values introduction-stack [ - [ fixup-enter-recursive ] - [ child>> [ eliminate-introductions* ] change-each ] bi +: eliminate-introductions ( nodes introductions -- nodes ) + introduction-stack [ + [ eliminate-introductions* ] map ] with-variable ; +: eliminate-toplevel-introductions ( nodes -- nodes' ) + dup count-introductions make-values + [ nip [ #introduce ] map ] [ eliminate-introductions ] 2bi + append ; + +: eliminate-recursive-introductions ( recursive n -- ) + make-values + [ swap fixup-enter-recursive ] + [ '[ , eliminate-introductions ] change-child drop ] + 2bi ; + ! Normalize GENERIC: normalize* ( node -- node' ) M: #recursive normalize* - dup dup label>> introductions>> eliminate-introductions ; + dup dup label>> introductions>> + eliminate-recursive-introductions ; : unchanged-underneath ( #call-recursive -- n ) [ out-d>> length ] [ label>> return>> in-d>> length ] bi - ; @@ -123,6 +140,6 @@ M: #call-recursive normalize* M: node normalize* ; : normalize ( nodes -- nodes' ) - [ [ collect-label-info ] each-node ] - [ [ normalize* ] map-nodes ] - bi ; + dup [ collect-label-info ] each-node + eliminate-toplevel-introductions + [ normalize* ] map-nodes ; diff --git a/unfinished/compiler/tree/tree.factor b/unfinished/compiler/tree/tree.factor index 2a6e6cfa2f..196c3e3658 100755 --- a/unfinished/compiler/tree/tree.factor +++ b/unfinished/compiler/tree/tree.factor @@ -87,10 +87,11 @@ TUPLE: #dispatch < #branch ; : #dispatch ( n branches -- node ) \ #dispatch new-branch ; -TUPLE: #phi < node phi-in-d phi-info-d phi-in-r phi-info-r out-d out-r ; +TUPLE: #phi < node phi-in-d phi-info-d phi-in-r phi-info-r out-d out-r terminated ; -: #phi ( d-phi-in d-phi-out r-phi-in r-phi-out -- node ) +: #phi ( d-phi-in d-phi-out r-phi-in r-phi-out terminated -- node ) \ #phi new + swap >>terminated swap >>out-r swap >>phi-in-r swap >>out-d diff --git a/unfinished/stack-checker/branches/branches.factor b/unfinished/stack-checker/branches/branches.factor index 4b63e540dc..c4a89deb05 100644 --- a/unfinished/stack-checker/branches/branches.factor +++ b/unfinished/stack-checker/branches/branches.factor @@ -58,9 +58,17 @@ SYMBOL: quotations unify-branches [ drop ] [ ] [ dup >vector meta-r set ] tri* ; +: terminated-phi ( seq -- terminated ) + terminated? branch-variable ; + : compute-phi-function ( seq -- ) [ quotation active-variable sift quotations set ] - [ [ datastack-phi ] [ retainstack-phi ] bi #phi, ] + [ + [ datastack-phi ] + [ retainstack-phi ] + [ terminated-phi ] + tri #phi, + ] [ [ terminated? swap at ] all? terminated? set ] tri ; diff --git a/unfinished/stack-checker/visitor/dummy/dummy.factor b/unfinished/stack-checker/visitor/dummy/dummy.factor index 7ab13fdd47..a1ed5c83a1 100644 --- a/unfinished/stack-checker/visitor/dummy/dummy.factor +++ b/unfinished/stack-checker/visitor/dummy/dummy.factor @@ -17,7 +17,7 @@ M: f #return-recursive, 3drop ; M: f #terminate, drop ; M: f #if, 3drop ; M: f #dispatch, 2drop ; -M: f #phi, 2drop 2drop ; +M: f #phi, drop drop drop drop drop ; M: f #declare, drop ; M: f #recursive, 2drop 2drop ; M: f #copy, 2drop ; diff --git a/unfinished/stack-checker/visitor/visitor.factor b/unfinished/stack-checker/visitor/visitor.factor index ce30d12c7e..3afc8f752d 100644 --- a/unfinished/stack-checker/visitor/visitor.factor +++ b/unfinished/stack-checker/visitor/visitor.factor @@ -20,7 +20,7 @@ HOOK: #r>, stack-visitor ( inputs outputs -- ) HOOK: #terminate, stack-visitor ( stack -- ) HOOK: #if, stack-visitor ( ? true false -- ) HOOK: #dispatch, stack-visitor ( n branches -- ) -HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- ) +HOOK: #phi, stack-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out terminated -- ) HOOK: #declare, stack-visitor ( declaration -- ) HOOK: #return, stack-visitor ( stack -- ) HOOK: #enter-recursive, stack-visitor ( label inputs outputs -- )