--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.branch-fusion
+
+: fuse-branches ( nodes -- nodes' ) ;
stack-checker.backend compiler.tree ;
IN: compiler.tree.builder
-: with-tree-builder ( quot -- dataflow )
- [ node-list new stack-visitor set ] prepose
- with-infer first>> ; inline
+: with-tree-builder ( quot -- nodes )
+ [ V{ } clone stack-visitor set ] prepose
+ with-infer ; inline
-GENERIC# build-tree-with 1 ( quot stack -- dataflow )
+GENERIC# build-tree-with 1 ( quot stack -- nodes )
M: callable build-tree-with
#! Not safe to call from inference transforms.
f infer-quot
] with-tree-builder nip ;
-: build-tree ( quot -- dataflow ) f build-tree-with ;
+: build-tree ( quot -- nodes ) f build-tree-with ;
: (make-specializer) ( class picker -- quot )
swap "predicate" word-prop append ;
[ drop ]
} cond ;
-: build-tree-from-word ( word -- effect dataflow )
+: build-tree-from-word ( word -- effect nodes )
[
[
dup +cannot-infer+ word-prop [ cannot-infer-effect ] when
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.cleanup
+
+: cleanup ( nodes -- nodes' ) ;
IN: compiler.tree.combinators.tests
-USING: compiler.tree.combinators compiler.tree.builder tools.test
-kernel ;
-
-[ ] [ [ 1 ] build-tree [ ] transform-nodes drop ] unit-test
-[ ] [ [ 1 2 3 ] build-tree [ ] transform-nodes drop ] unit-test
-
-{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as
-
-{ 1 0 }
-[
- [ [ iterate-next ] iterate-nodes ] with-node-iterator
-] must-infer-as
+USING: compiler.tree.combinators tools.test kernel ;
{ 1 0 } [ [ drop ] each-node ] must-infer-as
-
-{ 1 0 } [ [ ] map-children ] must-infer-as
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: fry arrays generic assocs kernel math namespaces parser
-sequences words vectors math.intervals effects classes
-accessors combinators compiler.tree ;
+USING: fry kernel accessors sequences compiler.tree ;
IN: compiler.tree.combinators
-SYMBOL: node-stack
-
-: >node ( node -- ) node-stack get push ;
-: node> ( -- node ) node-stack get pop ;
-: node@ ( -- node ) node-stack get peek ;
-
-: iterate-next ( -- node ) node@ successor>> ;
-
-: iterate-nodes ( node quot -- )
- over [
- [ swap >node call node> drop ] keep iterate-nodes
- ] [
- 2drop
- ] if ; inline
-
-: (each-node) ( quot -- next )
- node@ [ swap call ] 2keep
- children>> [
- first>> [
- [ (each-node) ] keep swap
- ] iterate-nodes
- ] each drop
- iterate-next ; inline
-
-: with-node-iterator ( quot -- )
- >r V{ } clone node-stack r> with-variable ; inline
-
-: each-node ( node quot -- )
- [
- swap [
- [ (each-node) ] keep swap
- ] iterate-nodes drop
- ] with-node-iterator ; inline
-
-: map-children ( node quot -- )
- [ children>> ] dip '[ , change-first drop ] each ; inline
-
-: (transform-nodes) ( prev node quot -- )
- dup >r call dup [
- >>successor
- successor>> dup successor>>
- r> (transform-nodes)
- ] [
- r> 2drop f >>successor drop
- ] if ; inline
-
-: transform-nodes ( node quot -- new-node )
- over [
- [ call dup dup successor>> ] keep (transform-nodes)
- ] [ drop ] if ; inline
-
-: tail-call? ( -- ? )
- #! We don't consider calls which do non-local exits to be
- #! tail calls, because this gives better error traces.
- node-stack get [
- successor>> [ #tail? ] [ #terminate? not ] bi and
- ] all? ;
+: each-node ( nodes quot -- )
+ dup dup '[
+ , [
+ dup #branch? [
+ children>> [ , each-node ] each
+ ] [
+ dup #recursive? [
+ child>> , each-node
+ ] [ drop ] if
+ ] if
+ ] bi
+ ] each ; inline
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.dataflow-analysis.backward
+USING: accessors sequences assocs kernel compiler.tree
+compiler.tree.dataflow-analysis ;
+
+GENERIC: backward ( value node -- )
+
+M: #copy backward
+ #! If the output of a copy is live, then the corresponding
+ #! input is live also.
+ [ out-d>> index ] keep in-d>> nth look-at-value ;
+
+M: #call backward
+ #! If any of the outputs of a call are live, then all
+ #! inputs and outputs must be live.
+ nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+
+M: #call-recursive backward
+ #! If the output of a copy is live, then the corresponding
+ #! inputs to #return nodes are live also.
+ [ out-d>> <reversed> index ] keep label>> returns>>
+ [ <reversed> nth look-at-value ] with each ;
+
+M: #>r backward nip in-d>> first look-at-value ;
+
+M: #r> backward nip in-r>> first look-at-value ;
+
+M: #shuffle backward mapping>> at look-at-value ;
+
+M: #phi backward
+ #! If any of the outputs of a #phi are live, then the
+ #! corresponding inputs are live too.
+ [ [ out-d>> ] [ phi-in-d>> ] bi look-at-corresponding ]
+ [ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
+ 2bi ;
+
+M: node backward 2drop ;
+
+: backward-dfa ( node quot -- assoc ) [ backward ] dfa ; inline
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry accessors namespaces assocs dequeues search-dequeues
+kernel sequences words sets stack-checker.inlining compiler.tree
+compiler.tree.def-use compiler.tree.combinators ;
+IN: compiler.tree.dataflow-analysis
+
+! Dataflow analysis
+SYMBOL: work-list
+
+: look-at-value ( values -- )
+ work-list get push-front ;
+
+: look-at-values ( values -- )
+ work-list get '[ , push-front ] each ;
+
+: look-at-inputs ( node -- ) in-d>> look-at-values ;
+
+: look-at-outputs ( node -- ) out-d>> look-at-values ;
+
+: look-at-corresponding ( value inputs outputs -- )
+ [ index ] dip over [ nth look-at-values ] [ 2drop ] if ;
+
+: init-dfa ( -- )
+ #! We add f initially because #phi nodes can have f in their
+ #! inputs.
+ <hashed-dlist> work-list set ;
+
+: iterate-dfa ( value assoc quot -- )
+ 2over key? [
+ 3drop
+ ] [
+ [ dupd conjoin dup defined-by ] dip call
+ ] if ; inline
+
+: dfa ( node mark-quot iterate-quot -- assoc )
+ init-dfa
+ [ each-node ] dip
+ work-list get H{ { f f } } clone
+ [ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline
USING: fry accessors namespaces assocs dequeues search-dequeues
kernel sequences words sets stack-checker.inlining
compiler.tree
-compiler.tree.dfa
-compiler.tree.dfa.backward
+compiler.tree.dataflow-analysis
+compiler.tree.dataflow-analysis.backward
compiler.tree.combinators ;
IN: compiler.tree.dead-code
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs sequences kernel generic assocs classes
-vectors accessors combinators sets stack-checker.state
+USING: arrays namespaces assocs sequences kernel generic assocs
+classes vectors accessors combinators sets stack-checker.state
compiler.tree compiler.tree.combinators ;
IN: compiler.tree.def-use
TUPLE: definition value node uses ;
-: <definition> ( value -- definition )
+: <definition> ( node value -- definition )
definition new
swap >>value
+ swap >>node
V{ } clone >>uses ;
: def-of ( value -- definition )
- def-use get [ <definition> ] cache ;
+ def-use get at* [ "No def" throw ] unless ;
: def-value ( node value -- )
- def-of [ [ "Multiple defs" throw ] when ] change-node drop ;
+ def-use get 2dup key? [
+ "Multiple defs" throw
+ ] [
+ [ [ <definition> ] keep ] dip set-at
+ ] if ;
: used-by ( value -- nodes ) def-of uses>> ;
: use-value ( node value -- ) used-by push ;
-: defined-by ( value -- node ) def-use get at node>> ;
+: defined-by ( value -- node ) def-of node>> ;
GENERIC: node-uses-values ( node -- values )
-M: #declare node-uses-values declaration>> keys ;
-
-M: #phi node-uses-values
- [ phi-in-d>> concat ] [ phi-in-r>> concat ] bi
- append sift prune ;
-
+M: #introduce node-uses-values drop f ;
+M: #push node-uses-values drop f ;
M: #r> node-uses-values in-r>> ;
-
+M: #phi node-uses-values
+ [ phi-in-d>> ] [ phi-in-r>> ] bi append concat sift prune ;
+M: #declare node-uses-values declaration>> keys ;
M: node node-uses-values in-d>> ;
GENERIC: node-defs-values ( node -- values )
-M: #introduce node-defs-values values>> ;
-
+M: #introduce node-defs-values value>> 1array ;
M: #>r node-defs-values out-r>> ;
-
+M: #branch node-defs-values drop f ;
M: #phi node-defs-values [ out-d>> ] [ out-r>> ] bi append ;
-
+M: #declare node-defs-values drop f ;
+M: #return node-defs-values drop f ;
+M: #recursive node-defs-values drop f ;
+M: #terminate node-defs-values drop f ;
M: node node-defs-values out-d>> ;
: node-def-use ( node -- )
[ dup node-uses-values [ use-value ] with each ]
[ dup node-defs-values [ def-value ] with each ] bi ;
-: check-def ( node -- )
- [ "No def" throw ] unless ;
-
: check-use ( uses -- )
[ empty? [ "No use" throw ] when ]
[ all-unique? [ "Uses not all unique" throw ] unless ] bi ;
: check-def-use ( -- )
- def-use get [
- nip [ node>> check-def ] [ uses>> check-use ] bi
- ] assoc-each ;
+ def-use get [ nip uses>> check-use ] assoc-each ;
: compute-def-use ( node -- node )
H{ } clone def-use set
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: compiler.tree.dfa.backward
-USING: accessors sequences assocs kernel compiler.tree
-compiler.tree.dfa ;
-
-GENERIC: backward ( value node -- )
-
-M: #copy backward
- #! If the output of a copy is live, then the corresponding
- #! input is live also.
- [ out-d>> index ] keep in-d>> nth look-at-value ;
-
-M: #call backward
- #! If any of the outputs of a call are live, then all
- #! inputs and outputs must be live.
- nip [ look-at-inputs ] [ look-at-outputs ] bi ;
-
-M: #call-recursive backward
- #! If the output of a copy is live, then the corresponding
- #! inputs to #return nodes are live also.
- [ out-d>> <reversed> index ] keep label>> returns>>
- [ <reversed> nth look-at-value ] with each ;
-
-M: #>r backward nip in-d>> first look-at-value ;
-
-M: #r> backward nip in-r>> first look-at-value ;
-
-M: #shuffle backward mapping>> at look-at-value ;
-
-M: #phi backward
- #! If any of the outputs of a #phi are live, then the
- #! corresponding inputs are live too.
- [ [ out-d>> ] [ phi-in-d>> ] bi look-at-corresponding ]
- [ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
- 2bi ;
-
-M: node backward 2drop ;
-
-: backward-dfa ( node quot -- assoc ) [ backward ] dfa ; inline
+++ /dev/null
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: fry accessors namespaces assocs dequeues search-dequeues
-kernel sequences words sets stack-checker.inlining compiler.tree
-compiler.tree.def-use compiler.tree.combinators ;
-IN: compiler.tree.dfa
-
-! Dataflow analysis
-SYMBOL: work-list
-
-: look-at-value ( values -- )
- work-list get push-front ;
-
-: look-at-values ( values -- )
- work-list get '[ , push-front ] each ;
-
-: look-at-inputs ( node -- ) in-d>> look-at-values ;
-
-: look-at-outputs ( node -- ) out-d>> look-at-values ;
-
-: look-at-corresponding ( value inputs outputs -- )
- [ index ] dip over [ nth look-at-values ] [ 2drop ] if ;
-
-: init-dfa ( -- )
- #! We add f initially because #phi nodes can have f in their
- #! inputs.
- <hashed-dlist> work-list set ;
-
-: iterate-dfa ( value assoc quot -- )
- 2over key? [
- 3drop
- ] [
- [ dupd conjoin dup defined-by ] dip call
- ] if ; inline
-
-: dfa ( node mark-quot iterate-quot -- assoc )
- init-dfa
- [ each-node ] dip
- work-list get H{ { f f } } clone
- [ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.loop-detection
+
+: detect-loops ( nodes -- nodes' ) ;
--- /dev/null
+IN: compiler.tree.normalization.tests
+USING: compiler.tree.builder compiler.tree.normalization
+compiler.tree sequences accessors tools.test kernel ;
+
+\ collect-introductions must-infer
+\ fixup-enter-recursive must-infer
+\ eliminate-introductions must-infer
+\ normalize must-infer
+
+[ 3 ] [ [ 3drop 1 2 3 ] build-tree collect-introductions ] unit-test
+
+[ 4 ] [ [ 3drop 1 2 3 3drop drop ] build-tree collect-introductions ] unit-test
+
+[ 3 ] [ [ [ drop ] [ 2drop 3 ] if ] build-tree collect-introductions ] unit-test
+
+[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree collect-introductions ] unit-test
+
+: foo ( -- ) swap ; inline recursive
+
+: recursive-inputs ( nodes -- n )
+ [ #recursive? ] find nip child>> first in-d>> length ;
+
+[ 0 2 ] [
+ [ foo ] build-tree
+ [ recursive-inputs ]
+ [ normalize recursive-inputs ] bi
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces sequences math accessors kernel arrays
+stack-checker.backend compiler.tree compiler.tree.combinators ;
+IN: compiler.tree.normalization
+
+! A transform pass done before optimization can begin to
+! 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.
+!
+! - We collect #return-recursive and #call-recursive nodes and
+! store them in the #recursive's label slot.
+
+GENERIC: normalize* ( node -- )
+
+! Collect introductions
+SYMBOL: introductions
+
+GENERIC: collect-introductions* ( node -- )
+
+: collect-introductions ( nodes -- n )
+ [
+ 0 introductions set
+ [ collect-introductions* ] each
+ introductions get
+ ] with-scope ;
+
+M: #introduce collect-introductions* drop introductions inc ;
+
+M: #branch collect-introductions*
+ children>>
+ [ collect-introductions ] map supremum
+ introductions [ + ] change ;
+
+M: node collect-introductions* drop ;
+
+! Eliminate introductions
+SYMBOL: introduction-stack
+
+: fixup-enter-recursive ( recursive -- )
+ [ child>> first ] [ in-d>> ] bi >>in-d
+ [ introduction-stack get prepend ] change-out-d
+ drop ;
+
+GENERIC: eliminate-introductions* ( node -- node' )
+
+: pop-introduction ( -- value )
+ introduction-stack [ unclip-last swap ] change ;
+
+M: #introduce eliminate-introductions*
+ pop-introduction swap value>> [ 1array ] bi@ #copy ;
+
+SYMBOL: remaining-introductions
+
+M: #branch eliminate-introductions*
+ dup children>> [
+ [
+ [ eliminate-introductions* ] change-each
+ introduction-stack get
+ ] with-scope
+ ] map
+ [ remaining-introductions set ]
+ [ [ length ] map infimum introduction-stack [ swap head ] change ]
+ bi ;
+
+M: #phi eliminate-introductions*
+ remaining-introductions get swap
+ [ flip [ over length tail append ] 2map flip ] change-phi-in-d ;
+
+M: node eliminate-introductions* ;
+
+: eliminate-introductions ( recursive n -- )
+ make-values introduction-stack set
+ [ fixup-enter-recursive ]
+ [ child>> [ eliminate-introductions* ] change-each ] bi ;
+
+M: #recursive normalize*
+ [
+ [ child>> collect-introductions ]
+ [ swap eliminate-introductions ]
+ bi
+ ] with-scope ;
+
+! Collect label info
+M: #return-recursive normalize* dup label>> (>>return) ;
+
+M: #call-recursive normalize* dup label>> calls>> push ;
+
+M: node normalize* drop ;
+
+: normalize ( node -- node ) dup [ normalize* ] each-node ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.tree.normalization compiler.tree.copy-equiv
+compiler.tree.propagation compiler.tree.cleanup
+compiler.tree.def-use compiler.tree.untupling
+compiler.tree.dead-code compiler.tree.strength-reduction
+compiler.tree.loop-detection compiler.tree.branch-fusion ;
+IN: compiler.tree.optimizer
+
+: optimize-tree ( nodes -- nodes' )
+ normalize
+ compute-copy-equiv
+ propagate
+ cleanup
+ compute-def-use
+ unbox-tuples
+ compute-def-use
+ remove-dead-code
+ strength-reduce
+ detect-loops
+ fuse-branches ;
[ children>> ] [ in-d>> first value-info interval>> ] bi
'[ , interval-contains? [ drop f ] unless ] map-index ;
-: infer-children ( node -- assocs )
+SYMBOL: infer-children-data
+
+: infer-children ( node -- )
[ live-children ] [ child-constraints ] bi [
[
over [
value-infos [ clone ] change
constraints [ clone ] change
assume
- first>> (propagate)
+ (propagate)
] [
2drop
value-infos off
constraints off
] if
] H{ } make-assoc
- ] 2map ;
+ ] 2map infer-children-data set ;
: (merge-value-infos) ( inputs results -- infos )
'[ , [ [ value-info ] bind ] 2map value-infos-union ] map ;
: merge-value-infos ( results inputs outputs -- )
[ swap (merge-value-infos) ] dip set-value-infos ;
-: propagate-branch-phi ( results #phi -- )
+M: #phi propagate-before ( #phi -- )
+ infer-children-data get swap
[ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
[ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
2bi ;
] [ 3drop ] if
] 2each ;
-: merge-children ( results node -- )
- [ successor>> propagate-branch-phi ]
- [ [ in-d>> first ] [ successor>> ] bi 2drop ] ! branch-phi-constraints ]
- bi ;
+! : merge-children
+! [ successor>> propagate-branch-phi ]
+! [ [ in-d>> first ] [ successor>> ] bi 2drop ] ! branch-phi-constraints ]
+! bi ;
M: #branch propagate-around
- [ infer-children ] [ merge-children ] [ annotate-node ] tri ;
+ [ infer-children ] [ annotate-node ] bi ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.propagation.inlining
GENERIC: propagate-around ( node -- )
-: (propagate) ( node -- )
- [
- USING: classes prettyprint ; dup class .
- [ propagate-around ] [ successor>> ] bi
- (propagate)
- ] when* ;
+: (propagate) ( node -- ) [ [ propagate-around ] each ] when* ;
USING: kernel compiler.tree.builder compiler.tree
compiler.tree.propagation compiler.tree.copy-equiv
-compiler.tree.def-use tools.test math math.order
+compiler.tree.normalization tools.test math math.order
accessors sequences arrays kernel.private vectors
alien.accessors alien.c-types sequences.private
byte-arrays classes.algebra classes.tuple.private
: final-info ( quot -- seq )
build-tree
- compute-def-use
+ normalize
compute-copy-equiv
propagate
- last-node node-input-infos ;
+ peek node-input-infos ;
: final-classes ( quot -- seq )
final-info [ class>> ] map ;
iter-counter inc
iter-counter get 10 > [ "Oops" throw ] when
dup label>> t >>fixed-point drop
- [ node-child first>> [ propagate-recursive-phi ] [ (propagate) ] bi ]
+ [ child>> [ first propagate-recursive-phi ] [ (propagate) ] bi ]
[ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ]
bi ;
IN: compiler.tree.propagation.simple
M: #introduce propagate-before
- object <class-info> swap values>> [ set-value-info ] with each ;
+ value>> object <class-info> swap set-value-info ;
M: #push propagate-before
[ literal>> value>> <literal-info> ] [ out-d>> first ] bi
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.strength-reduction
+
+: strength-reduce ( nodes -- nodes' ) ;
IN: compiler.tree
! High-level tree SSA form.
-!
-! Invariants:
-! 1) Each value has exactly one definition. A "definition" means
-! the value appears in the out-d or out-r slot of a node, or the
-! values slot of an #introduce node.
-! 2) Each value appears only once in the inputs of a node, where
-! the inputs are the concatenation of in-d and in-r, or in the
-! case of a #phi node, the sequence of sequences in the phi-in-r
-! and phi-in-d slots.
-! 3) A value is never used in the same node where it is defined.
-TUPLE: node < identity-tuple
-in-d out-d in-r out-r info
-successor children ;
-M: node hashcode* drop node hashcode* ;
-
-: node-child ( node -- child ) children>> first ;
+TUPLE: node < identity-tuple info ;
-: last-node ( node -- last )
- dup successor>> [ last-node ] [ ] ?if ;
-
-: penultimate-node ( node -- penultimate )
- dup successor>> dup [
- dup successor>>
- [ nip penultimate-node ] [ drop ] if
- ] [
- 2drop f
- ] if ;
+M: node hashcode* drop node hashcode* ;
-TUPLE: #introduce < node values ;
+TUPLE: #introduce < node value ;
-: #introduce ( values -- node )
- \ #introduce new swap >>values ;
+: #introduce ( value -- node )
+ \ #introduce new swap >>value ;
-TUPLE: #call < node word history ;
+TUPLE: #call < node word history in-d out-d ;
: #call ( inputs outputs word -- node )
\ #call new
swap >>out-d
swap >>in-d ;
-TUPLE: #call-recursive < node label ;
+TUPLE: #call-recursive < node label in-d out-d ;
: #call-recursive ( inputs outputs label -- node )
\ #call-recursive new
swap >>out-d
swap >>in-d ;
-TUPLE: #push < node literal ;
+TUPLE: #push < node literal out-d ;
: #push ( literal value -- node )
\ #push new
swap 1array >>out-d
swap >>literal ;
-TUPLE: #shuffle < node mapping ;
+TUPLE: #shuffle < node mapping in-d out-d ;
: #shuffle ( inputs outputs mapping -- node )
\ #shuffle new
: #drop ( inputs -- node )
{ } { } #shuffle ;
-TUPLE: #>r < node ;
+TUPLE: #>r < node in-d out-r ;
: #>r ( inputs outputs -- node )
\ #>r new
swap >>out-r
swap >>in-d ;
-TUPLE: #r> < node ;
+TUPLE: #r> < node in-r out-d ;
: #r> ( inputs outputs -- node )
\ #r> new
swap >>out-d
swap >>in-r ;
-TUPLE: #terminate < node ;
+TUPLE: #terminate < node in-d ;
: #terminate ( stack -- node )
\ #terminate new
swap >>in-d ;
-TUPLE: #branch < node ;
+TUPLE: #branch < node in-d children ;
: new-branch ( value children class -- node )
new
: #dispatch ( n branches -- node )
\ #dispatch new-branch ;
-TUPLE: #phi < node phi-in-d phi-in-r ;
+TUPLE: #phi < node phi-in-d phi-in-r out-d out-r ;
: #phi ( d-phi-in d-phi-out r-phi-in r-phi-out -- node )
\ #phi new
\ #declare new
swap >>declaration ;
-TUPLE: #return < node ;
+TUPLE: #return < node in-d ;
: #return ( stack -- node )
\ #return new
swap >>in-d ;
-TUPLE: #recursive < node word label loop? returns calls ;
+TUPLE: #recursive < node in-d word label loop? returns calls child ;
: #recursive ( word label inputs child -- node )
\ #recursive new
- swap 1array >>children
+ swap >>child
swap >>in-d
swap >>label
swap >>word ;
-TUPLE: #enter-recursive < node label ;
+TUPLE: #enter-recursive < node in-d out-d label ;
: #enter-recursive ( label inputs outputs -- node )
\ #enter-recursive new
swap >>in-d
swap >>label ;
-TUPLE: #return-recursive < node label ;
+TUPLE: #return-recursive < node in-d out-d label ;
: #return-recursive ( label inputs outputs -- node )
\ #return-recursive new
swap >>in-d
swap >>label ;
-TUPLE: #copy < node ;
+TUPLE: #copy < node in-d out-d ;
: #copy ( inputs outputs -- node )
\ #copy new
swap >>out-d
swap >>in-d ;
-DEFER: #tail?
-
-PREDICATE: #tail-phi < #phi successor>> #tail? ;
-
-UNION: #tail POSTPONE: f #return #tail-phi #terminate ;
-
-TUPLE: node-list first last ;
-
-: node, ( node -- )
- stack-visitor get swap
- over last>>
- [ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ]
- [ [ >>first ] [ >>last ] bi drop ]
- if ;
-
-M: node-list child-visitor node-list new ;
-M: node-list #introduce, #introduce node, ;
-M: node-list #call, #call node, ;
-M: node-list #push, #push node, ;
-M: node-list #shuffle, #shuffle node, ;
-M: node-list #drop, #drop node, ;
-M: node-list #>r, #>r node, ;
-M: node-list #r>, #r> node, ;
-M: node-list #return, #return node, ;
-M: node-list #enter-recursive, #enter-recursive node, ;
-M: node-list #return-recursive, #return-recursive [ node, ] [ dup label>> (>>return) ] bi ;
-M: node-list #call-recursive, #call-recursive [ node, ] [ dup label>> calls>> push ] bi ;
-M: node-list #terminate, #terminate node, ;
-M: node-list #if, #if node, ;
-M: node-list #dispatch, #dispatch node, ;
-M: node-list #phi, #phi node, ;
-M: node-list #declare, #declare node, ;
-M: node-list #recursive, #recursive node, ;
-M: node-list #copy, #copy node, ;
+: node, ( node -- ) stack-visitor get push ;
+
+M: vector child-visitor V{ } clone ;
+M: vector #introduce, #introduce node, ;
+M: vector #call, #call node, ;
+M: vector #push, #push node, ;
+M: vector #shuffle, #shuffle node, ;
+M: vector #drop, #drop node, ;
+M: vector #>r, #>r node, ;
+M: vector #r>, #r> node, ;
+M: vector #return, #return node, ;
+M: vector #enter-recursive, #enter-recursive node, ;
+M: vector #return-recursive, #return-recursive node, ;
+M: vector #call-recursive, #call-recursive node, ;
+M: vector #terminate, #terminate node, ;
+M: vector #if, #if node, ;
+M: vector #dispatch, #dispatch node, ;
+M: vector #phi, #phi node, ;
+M: vector #declare, #declare node, ;
+M: vector #recursive, #recursive node, ;
+M: vector #copy, #copy node, ;
USING: accessors slots.private kernel namespaces disjoint-sets
math sequences assocs classes.tuple.private combinators fry sets
compiler.tree compiler.tree.combinators compiler.tree.copy-equiv
-compiler.tree.dfa compiler.tree.dfa.backward ;
+compiler.tree.dataflow-analysis
+compiler.tree.dataflow-analysis.backward ;
IN: compiler.tree.untupling
SYMBOL: escaping-values
: pop-d ( -- obj )
meta-d get dup empty? [
- drop <value> dup 1array #introduce, d-in inc
+ drop <value> dup #introduce, d-in inc
] [ pop ] if ;
: peek-d ( -- obj ) pop-d dup push-d ;
: ensure-d ( n -- values ) consume-d dup output-d ;
+: make-values ( n -- values )
+ [ <value> ] replicate ;
+
: produce-d ( n -- values )
- [ <value> ] replicate dup meta-d get push-all ;
+ make-values dup meta-d get push-all ;
: push-r ( obj -- ) meta-r get push ;
: nest-visitor ( -- ) child-visitor stack-visitor set ;
-HOOK: #introduce, stack-visitor ( values -- )
+HOOK: #introduce, stack-visitor ( value -- )
HOOK: #call, stack-visitor ( inputs outputs word -- )
HOOK: #call-recursive, stack-visitor ( inputs outputs word -- )
HOOK: #push, stack-visitor ( literal value -- )
projects / factor.git / commitdiff