steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Change high-level IR to not use 'successor' links; add normalization pass

db4
Slava Pestov 2008-07-27 20:25:42 -05:00
parent 10322c11e3
commit 74197538f5
24 changed files with 280 additions and 210 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
unfinished/compiler/tree/branch-fusion/branch-fusion.factor Normal file
View File

@ -0,0 +1,5 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.branch-fusion
: fuse-branches ( nodes -- nodes' ) ;

12
unfinished/compiler/tree/builder/builder.factor
View File

@ -7,11 +7,11 @@ stack-checker.state stack-checker.visitor stack-checker.errors
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.
@ -20,7 +20,7 @@ M: callable build-tree-with
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 ;
@ -65,7 +65,7 @@ M: callable build-tree-with
[ 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

5
unfinished/compiler/tree/cleanup/cleanup.factor Normal file
View File

@ -0,0 +1,5 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.cleanup
: cleanup ( nodes -- nodes' ) ;

15
unfinished/compiler/tree/combinators/combinators-tests.factor
View File

@ -1,17 +1,4 @@
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

71
unfinished/compiler/tree/combinators/combinators.factor
View File

@ -1,64 +1,17 @@
! 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
: each-node ( nodes quot -- )
dup dup '[
, [
dup #branch? [
children>> [ , each-node ] each
] [
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? ;
dup #recursive? [
child>> , each-node
] [ drop ] if
] if
] bi
] each ; inline

4
unfinished/compiler/tree/dfa/backward/backward.factor → unfinished/compiler/tree/dataflow-analysis/backward/backward.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.dfa.backward
IN: compiler.tree.dataflow-analysis.backward
USING: accessors sequences assocs kernel compiler.tree
compiler.tree.dfa ;
compiler.tree.dataflow-analysis ;
GENERIC: backward ( value node -- )

2
unfinished/compiler/tree/dfa/dfa.factor → unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor
View File

@ -3,7 +3,7 @@
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
IN: compiler.tree.dataflow-analysis
! Dataflow analysis
SYMBOL: work-list

4
unfinished/compiler/tree/dead-code/dead-code.factor
View File

@ -3,8 +3,8 @@
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

48
unfinished/compiler/tree/def-use/def-use.factor
View File

@ -1,7 +1,7 @@
! 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
@ -9,60 +9,60 @@ SYMBOL: 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

5
unfinished/compiler/tree/loop-detection/loop-detection.factor Normal file
View File

@ -0,0 +1,5 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.loop-detection
: detect-loops ( nodes -- nodes' ) ;

27
unfinished/compiler/tree/normalization/normalization-tests.factor Normal file
View File

@ -0,0 +1,27 @@
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

94
unfinished/compiler/tree/normalization/normalization.factor Normal file
View File

@ -0,0 +1,94 @@
! 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 ;

21
unfinished/compiler/tree/optimizer/optimizer.factor Normal file
View File

@ -0,0 +1,21 @@
! 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 ;

21
unfinished/compiler/tree/propagation/branches/branches.factor
View File

@ -31,21 +31,23 @@ M: #dispatch live-children
[ 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 ;
@ -53,7 +55,8 @@ M: #dispatch live-children
: 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 ;
@ -67,10 +70,10 @@ M: #dispatch live-children
] [ 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 ;

3
unfinished/compiler/tree/propagation/inlining/inlining.factor Normal file
View File

@ -0,0 +1,3 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.propagation.inlining

7
unfinished/compiler/tree/propagation/nodes/nodes.factor
View File

@ -14,9 +14,4 @@ GENERIC: propagate-after ( node -- )
GENERIC: propagate-around ( node -- )
: (propagate) ( node -- )
[
USING: classes prettyprint ; dup class .
[ propagate-around ] [ successor>> ] bi
(propagate)
] when* ;
: (propagate) ( node -- ) [ [ propagate-around ] each ] when* ;

6
unfinished/compiler/tree/propagation/propagation-tests.factor
View File

@ -1,6 +1,6 @@
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
@ -13,10 +13,10 @@ IN: compiler.tree.propagation.tests
: 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 ;

2
unfinished/compiler/tree/propagation/recursive/recursive.factor
View File

@ -59,7 +59,7 @@ M: #recursive propagate-around ( #recursive -- )
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 ;

2
unfinished/compiler/tree/propagation/simple/simple.factor
View File

@ -13,7 +13,7 @@ compiler.tree.propagation.constraints ;
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

5
unfinished/compiler/tree/strength-reduction/strength-reduction.factor Normal file
View File

@ -0,0 +1,5 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: compiler.tree.strength-reduction
: strength-reduce ( nodes -- nodes' ) ;

117
unfinished/compiler/tree/tree.factor
View File

@ -6,41 +6,17 @@ accessors combinators stack-checker.state stack-checker.visitor ;
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 ;
TUPLE: node < identity-tuple info ;
M: node hashcode* drop node hashcode* ;
: node-child ( node -- child ) children>> first ;
TUPLE: #introduce < node value ;
: last-node ( node -- last )
dup successor>> [ last-node ] [ ] ?if ;
: #introduce ( value -- node )
\ #introduce new swap >>value ;
: penultimate-node ( node -- penultimate )
dup successor>> dup [
dup successor>>
[ nip penultimate-node ] [ drop ] if
] [
2drop f
] if ;
TUPLE: #introduce < node values ;
: #introduce ( values -- node )
\ #introduce new swap >>values ;
TUPLE: #call < node word history ;
TUPLE: #call < node word history in-d out-d ;
: #call ( inputs outputs word -- node )
\ #call new
@ -48,7 +24,7 @@ TUPLE: #call < node word history ;
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
@ -56,14 +32,14 @@ TUPLE: #call-recursive < node label ;
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
@ -74,27 +50,27 @@ TUPLE: #shuffle < node mapping ;
: #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
@ -111,7 +87,7 @@ TUPLE: #dispatch < #branch ;
: #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
@ -126,22 +102,22 @@ TUPLE: #declare < node declaration ;
\ #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
@ -149,7 +125,7 @@ TUPLE: #enter-recursive < node label ;
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
@ -157,44 +133,31 @@ TUPLE: #return-recursive < node label ;
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?
: node, ( node -- ) stack-visitor get push ;
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, ;
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, ;

3
unfinished/compiler/tree/untupling/untupling.factor
View File

@ -3,7 +3,8 @@
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

7
unfinished/stack-checker/backend/backend.factor
View File

@ -41,7 +41,7 @@ SYMBOL: visited
: 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 ;
@ -52,8 +52,11 @@ SYMBOL: visited
: 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 ;

2
unfinished/stack-checker/visitor/visitor.factor
View File

@ -9,7 +9,7 @@ HOOK: child-visitor stack-visitor ( -- visitor )
: 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 -- )