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

Working on sparse conditional constant propagation and untupling

db4
Slava Pestov 2008-07-23 23:50:21 -05:00
parent ef1e8ee8f6
commit 972619f50f
35 changed files with 732 additions and 431 deletions

6
unfinished/compiler/frontend/frontend-tests.factor
View File

@ -1,6 +0,0 @@
IN: compiler.frontend.tests
USING: compiler.frontend tools.test ;
\ dataflow must-infer
\ dataflow-with must-infer
\ word-dataflow must-infer

79
unfinished/compiler/frontend/frontend.factor
View File

@ -1,79 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors quotations kernel sequences namespaces assocs
words generic generic.standard generic.standard.engines arrays
kernel.private combinators vectors stack-checker
stack-checker.state stack-checker.visitor stack-checker.errors
stack-checker.backend compiler.tree.builder ;
IN: compiler.frontend
: with-dataflow ( quot -- dataflow )
[ tree-builder new dataflow-visitor set ] prepose
with-infer first>> ; inline
GENERIC# dataflow-with 1 ( quot stack -- dataflow )
M: callable dataflow-with
#! Not safe to call from inference transforms.
[
>vector meta-d set
f infer-quot
] with-dataflow nip ;
: dataflow ( quot -- dataflow ) f dataflow-with ;
: (make-specializer) ( class picker -- quot )
swap "predicate" word-prop append ;
: make-specializer ( classes -- quot )
dup length <reversed>
[ (picker) 2array ] 2map
[ drop object eq? not ] assoc-filter
dup empty? [ drop [ t ] ] [
[ (make-specializer) ] { } assoc>map
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ;
: specializer-cases ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
'[ , declare ] pick append
] { } map>assoc ;
: method-declaration ( method -- quot )
dup "method-generic" word-prop dispatch# object <array>
swap "method-class" word-prop prefix ;
: specialize-method ( quot method -- quot' )
method-declaration '[ , declare ] prepend ;
: specialize-quot ( quot specializer -- quot' )
specializer-cases alist>quot ;
: standard-method? ( method -- ? )
dup method-body? [
"method-generic" word-prop standard-generic?
] [ drop f ] if ;
: specialized-def ( word -- quot )
dup def>> swap {
{ [ dup standard-method? ] [ specialize-method ] }
{
[ dup "specializer" word-prop ]
[ "specializer" word-prop specialize-quot ]
}
[ drop ]
} cond ;
: word-dataflow ( word -- effect dataflow )
[
[
dup +cannot-infer+ word-prop [ cannot-infer-effect ] when
dup "no-compile" word-prop [ cannot-infer-effect ] when
dup specialized-def over dup 2array 1array infer-quot
finish-word
] maybe-cannot-infer
] with-dataflow ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;

10
unfinished/compiler/frontend/frontend-docs.factor → unfinished/compiler/tree/builder/builder-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax sequences quotations words
compiler.tree stack-checker.errors ;
IN: compiler.frontend
IN: compiler.tree.builder
ARTICLE: "specializers" "Word specializers"
"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class."
@ -22,15 +22,15 @@ $nl
"The specialized version of a word which will be compiled by the compiler can be inspected:"
{ $subsection specialized-def } ;
HELP: dataflow
HELP: build-tree
{ $values { "quot" quotation } { "dataflow" node } }
{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation." }
{ $description "Attempts to construct tree SSA IR from a quotation." }
{ $notes "This is the first stage of the compiler." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
HELP: dataflow-with
HELP: build-tree-with
{ $values { "quot" quotation } { "stack" sequence } { "dataflow" node } }
{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation, starting with an initial data stack of values." }
{ $description "Attempts to construct tree SSA IR from a quotaiton, starting with an initial data stack of values." }
{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
HELP: specialized-def

6
unfinished/compiler/tree/builder/builder-tests.factor Normal file
View File

@ -0,0 +1,6 @@
IN: compiler.tree.builder.tests
USING: compiler.tree.builder tools.test ;
\ build-tree must-infer
\ build-tree-with must-infer
\ build-tree-from-word must-infer

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

@ -1,32 +1,79 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors namespaces kernel sequences compiler.tree
stack-checker.visitor ;
USING: fry accessors quotations kernel sequences namespaces assocs
words generic generic.standard generic.standard.engines arrays
kernel.private combinators vectors stack-checker
stack-checker.state stack-checker.visitor stack-checker.errors
stack-checker.backend compiler.tree ;
IN: compiler.tree.builder
TUPLE: tree-builder first last ;
: with-tree-builder ( quot -- dataflow )
[ node-list new stack-visitor set ] prepose
with-infer first>> ; inline
: node, ( node -- )
dataflow-visitor get swap
over last>>
[ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ]
[ [ >>first ] [ >>last ] bi drop ]
if ;
GENERIC# build-tree-with 1 ( quot stack -- dataflow )
M: tree-builder child-visitor tree-builder new ;
M: tree-builder #introduce, #introduce node, ;
M: tree-builder #call, #call node, ;
M: tree-builder #call-recursive, #call-recursive node, ;
M: tree-builder #push, #push node, ;
M: tree-builder #shuffle, #shuffle node, ;
M: tree-builder #drop, #drop node, ;
M: tree-builder #>r, #>r node, ;
M: tree-builder #r>, #r> node, ;
M: tree-builder #return, #return node, ;
M: tree-builder #terminate, #terminate node, ;
M: tree-builder #if, [ first>> ] bi@ #if node, ;
M: tree-builder #dispatch, [ first>> ] map #dispatch node, ;
M: tree-builder #phi, #phi node, ;
M: tree-builder #declare, #declare node, ;
M: tree-builder #recursive, first>> #recursive node, ;
M: tree-builder #copy, #copy node, ;
M: callable build-tree-with
#! Not safe to call from inference transforms.
[
>vector meta-d set
f infer-quot
] with-tree-builder nip ;
: build-tree ( quot -- dataflow ) f build-tree-with ;
: (make-specializer) ( class picker -- quot )
swap "predicate" word-prop append ;
: make-specializer ( classes -- quot )
dup length <reversed>
[ (picker) 2array ] 2map
[ drop object eq? not ] assoc-filter
dup empty? [ drop [ t ] ] [
[ (make-specializer) ] { } assoc>map
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ;
: specializer-cases ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
'[ , declare ] pick append
] { } map>assoc ;
: method-declaration ( method -- quot )
dup "method-generic" word-prop dispatch# object <array>
swap "method-class" word-prop prefix ;
: specialize-method ( quot method -- quot' )
method-declaration '[ , declare ] prepend ;
: specialize-quot ( quot specializer -- quot' )
specializer-cases alist>quot ;
: standard-method? ( method -- ? )
dup method-body? [
"method-generic" word-prop standard-generic?
] [ drop f ] if ;
: specialized-def ( word -- quot )
dup def>> swap {
{ [ dup standard-method? ] [ specialize-method ] }
{
[ dup "specializer" word-prop ]
[ "specializer" word-prop specialize-quot ]
}
[ drop ]
} cond ;
: build-tree-from-word ( word -- effect dataflow )
[
[
dup +cannot-infer+ word-prop [ cannot-infer-effect ] when
dup "no-compile" word-prop [ cannot-infer-effect ] when
dup specialized-def over dup 2array 1array infer-quot
finish-word
] maybe-cannot-infer
] with-tree-builder ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;

1
unfinished/compiler/tree/co Normal file
View File

@ -0,0 +1 @@

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

@ -1,9 +1,9 @@
IN: compiler.tree.combinators.tests
USING: compiler.tree.combinators compiler.frontend tools.test
USING: compiler.tree.combinators compiler.tree.builder tools.test
kernel ;
[ ] [ [ 1 ] dataflow [ ] transform-nodes drop ] unit-test
[ ] [ [ 1 2 3 ] dataflow [ ] transform-nodes drop ] unit-test
[ ] [ [ 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

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

@ -5,18 +5,6 @@ sequences words vectors math.intervals effects classes
accessors combinators compiler.tree ;
IN: compiler.tree.combinators
: node-exists? ( node quot -- ? )
over [
2dup 2slip rot [
2drop t
] [
[ [ children>> ] [ successor>> ] bi suffix ] dip
'[ , node-exists? ] contains?
] if
] [
2drop f
] if ; inline
SYMBOL: node-stack
: >node ( node -- ) node-stack get push ;
@ -34,8 +22,8 @@ SYMBOL: node-stack
: (each-node) ( quot -- next )
node@ [ swap call ] 2keep
node-children [
[
children>> [
first>> [
[ (each-node) ] keep swap
] iterate-nodes
] each drop
@ -52,15 +40,7 @@ SYMBOL: node-stack
] with-node-iterator ; inline
: map-children ( node quot -- )
over [
over children>> [
'[ , map ] change-children drop
] [
2drop
] if
] [
2drop
] if ; inline
[ children>> ] dip '[ , change-first drop ] each ; inline
: (transform-nodes) ( prev node quot -- )
dup >r call dup [

50
unfinished/compiler/tree/comparisons/comparisons.factor Normal file
View File

@ -0,0 +1,50 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math math.order math.intervals assocs combinators ;
IN: compiler.tree.comparisons
! Some utilities for working with comparison operations.
: comparison-ops { < > <= >= } ;
: generic-comparison-ops { before? after? before=? after=? } ;
: assumption ( i1 i2 op -- i3 )
{
{ \ < [ assume< ] }
{ \ > [ assume> ] }
{ \ <= [ assume<= ] }
{ \ >= [ assume>= ] }
} case ;
: interval-comparison ( i1 i2 op -- result )
{
{ \ < [ interval< ] }
{ \ > [ interval> ] }
{ \ <= [ interval<= ] }
{ \ >= [ interval>= ] }
} case ;
: swap-comparison ( op -- op' )
{
{ < > }
{ > < }
{ <= >= }
{ >= <= }
} at ;
: negate-comparison ( op -- op' )
{
{ < >= }
{ > <= }
{ <= > }
{ >= < }
} at ;
: specific-comparison ( op -- op' )
{
{ before? < }
{ after? > }
{ before=? <= }
{ after=? >= }
} at ;

42
unfinished/compiler/tree/copy-equiv/copy-equiv.factor Normal file
View File

@ -0,0 +1,42 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces disjoint-sets sequences assocs
kernel accessors fry
compiler.tree compiler.tree.def-use compiler.tree.combinators ;
IN: compiler.tree.copy-equiv
! Disjoint set of copy equivalence
SYMBOL: copies
: is-copy-of ( val copy -- ) copies get equate ;
: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
: resolve-copy ( copy -- val ) copies get representative ;
: introduce-value ( val -- ) copies get add-atom ;
GENERIC: compute-copy-equiv* ( node -- )
M: #shuffle compute-copy-equiv*
[ out-d>> dup ] [ mapping>> ] bi
'[ , at ] map swap are-copies-of ;
M: #>r compute-copy-equiv*
[ in-d>> ] [ out-r>> ] bi are-copies-of ;
M: #r> compute-copy-equiv*
[ in-r>> ] [ out-d>> ] bi are-copies-of ;
M: #copy compute-copy-equiv*
[ in-d>> ] [ out-d>> ] bi are-copies-of ;
M: node compute-copy-equiv* drop ;
: compute-copy-equiv ( node -- node )
<disjoint-set> copies set
dup [
[ node-defs-values [ introduce-value ] each ]
[ compute-copy-equiv* ]
bi
] each-node ;

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

@ -1,4 +1,4 @@
USING: namespaces assocs sequences compiler.frontend
USING: namespaces assocs sequences compiler.tree.builder
compiler.tree.dead-code compiler.tree.def-use compiler.tree
compiler.tree.combinators tools.test kernel math
stack-checker.state accessors ;
@ -7,7 +7,7 @@ IN: compiler.tree.dead-code.tests
\ remove-dead-code must-infer
: count-live-values ( quot -- n )
dataflow
build-tree
compute-def-use
remove-dead-code
compute-def-use

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

@ -1,106 +1,44 @@
! 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.combinators compiler.tree.def-use ;
kernel sequences words sets stack-checker.inlining
compiler.tree
compiler.tree.dfa
compiler.tree.dfa.backward
compiler.tree.combinators ;
IN: compiler.tree.dead-code
! Dead code elimination: remove #push and flushable #call whose
! outputs are unused.
SYMBOL: live-values
SYMBOL: work-list
: live-value? ( value -- ? )
live-values get at ;
: look-at-value ( values -- )
work-list get push-front ;
: look-at-values ( values -- )
work-list get '[ , push-front ] each ;
! outputs are unused using backward DFA.
GENERIC: mark-live-values ( node -- )
: look-at-inputs ( node -- ) in-d>> look-at-values ;
: look-at-outputs ( node -- ) out-d>> look-at-values ;
M: #introduce mark-live-values look-at-outputs ;
M: #if mark-live-values look-at-inputs ;
M: #dispatch mark-live-values look-at-inputs ;
M: #call mark-live-values
dup word>> "flushable" word-prop [ drop ] [
[ look-at-inputs ]
[ look-at-outputs ]
bi
] if ;
dup word>> "flushable" word-prop
[ drop ] [ [ look-at-inputs ] [ look-at-outputs ] bi ] if ;
M: #return mark-live-values
#! Values returned by local #recursive functions can be
#! killed if they're unused.
dup label>>
[ drop ] [ look-at-inputs ] if ;
dup label>> [ drop ] [ look-at-inputs ] if ;
M: node mark-live-values drop ;
GENERIC: propagate* ( value node -- )
SYMBOL: live-values
M: #copy propagate*
#! 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 propagate*
#! 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 propagate*
#! 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 propagate* nip in-d>> first look-at-value ;
M: #r> propagate* nip in-r>> first look-at-value ;
M: #shuffle propagate* mapping>> at look-at-value ;
: look-at-corresponding ( value inputs outputs -- )
[ index ] dip over [ nth look-at-values ] [ 2drop ] if ;
M: #phi propagate*
#! 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 propagate* 2drop ;
: propogate-liveness ( value -- )
live-values get 2dup key? [
2drop
] [
dupd conjoin
dup defined-by propagate*
] if ;
: live-value? ( value -- ? ) live-values get at ;
: compute-live-values ( node -- )
#! We add f initially because #phi nodes can have f in their
#! inputs.
<hashed-dlist> work-list set
H{ { f f } } clone live-values set
[ mark-live-values ] each-node
work-list get [ propogate-liveness ] slurp-dequeue ;
[ mark-live-values ] backward-dfa live-values set ;
GENERIC: remove-dead-values* ( node -- )
M: #introduce remove-dead-values*
[ [ live-value? ] filter ] change-values drop ;
M: #>r remove-dead-values*
dup out-r>> first live-value? [ { } >>out-r ] unless
dup in-d>> first live-value? [ { } >>in-d ] unless
@ -118,13 +56,6 @@ M: #push remove-dead-values*
: filter-corresponding-values ( in out -- in' out' )
zip live-values get '[ drop _ , key? ] assoc-filter unzip ;
: remove-dead-copies ( node -- )
dup
[ in-d>> ] [ out-d>> ] bi
filter-corresponding-values
[ >>in-d ] [ >>out-d ] bi*
drop ;
: filter-live ( values -- values' )
[ live-value? ] filter ;
@ -133,9 +64,16 @@ M: #shuffle remove-dead-values*
[ filter-live ] change-out-d
drop ;
M: #declare remove-dead-values* remove-dead-copies ;
M: #declare remove-dead-values*
[ [ drop live-value? ] assoc-filter ] change-declaration
drop ;
M: #copy remove-dead-values* remove-dead-copies ;
M: #copy remove-dead-values*
dup
[ in-d>> ] [ out-d>> ] bi
filter-corresponding-values
[ >>in-d ] [ >>out-d ] bi*
drop ;
: remove-dead-phi-d ( #phi -- #phi )
dup
@ -156,46 +94,54 @@ M: #phi remove-dead-values*
M: node remove-dead-values* drop ;
M: f remove-dead-values* drop ;
GENERIC: remove-dead-nodes* ( node -- newnode/t )
: prune-if-empty ( node seq -- successor/t )
empty? [ successor>> ] [ drop t ] if ; inline
M: #introduce remove-dead-nodes* dup values>> prune-if-empty ;
: live-call? ( #call -- ? )
out-d>> [ live-value? ] contains? ;
M: #declare remove-dead-nodes* dup declaration>> prune-if-empty ;
M: #call remove-dead-nodes*
dup live-call? [ drop t ] [
[ in-d>> #drop ] [ successor>> ] bi >>successor
] if ;
: prune-if ( node quot -- successor/t )
over >r call [ r> successor>> ] [ r> drop t ] if ;
inline
M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ;
M: #shuffle remove-dead-nodes*
[ in-d>> empty? ] prune-if ;
M: #push remove-dead-nodes* dup out-d>> prune-if-empty ;
M: #push remove-dead-nodes*
[ out-d>> empty? ] prune-if ;
M: #>r remove-dead-nodes* dup in-d>> prune-if-empty ;
M: #>r remove-dead-nodes*
[ in-d>> empty? ] prune-if ;
M: #r> remove-dead-nodes* dup in-r>> prune-if-empty ;
M: #r> remove-dead-nodes*
[ in-r>> empty? ] prune-if ;
M: #copy remove-dead-nodes* dup in-d>> prune-if-empty ;
: (remove-dead-code) ( node -- newnode )
[
dup remove-dead-values*
dup remove-dead-nodes* dup t eq?
[ drop ] [ nip (remove-dead-code) ] if
] transform-nodes ;
M: #if remove-dead-nodes*
[ (remove-dead-code) ] map-children t ;
M: #dispatch remove-dead-nodes*
[ (remove-dead-code) ] map-children t ;
M: #recursive remove-dead-nodes*
[ (remove-dead-code) ] change-child drop t ;
M: node remove-dead-nodes* drop t ;
: (remove-dead-code) ( node -- newnode )
dup [
dup remove-dead-values*
dup remove-dead-nodes* dup t eq? [
drop dup [ (remove-dead-code) ] map-children
] [
nip (remove-dead-code)
] if
] when ;
M: f remove-dead-nodes* drop t ;
: remove-dead-code ( node -- newnode )
[
[ compute-live-values ]
[ [ (remove-dead-code) ] transform-nodes ] bi
] with-scope ;
[ [ compute-live-values ] [ (remove-dead-code) ] bi ] with-scope ;

6
unfinished/compiler/tree/def-use/def-use-tests.factor
View File

@ -1,13 +1,13 @@
USING: accessors namespaces assocs kernel sequences math
tools.test words sets combinators.short-circuit
stack-checker.state compiler.tree compiler.frontend
stack-checker.state compiler.tree compiler.tree.builder
compiler.tree.def-use arrays kernel.private ;
IN: compiler.tree.def-use.tests
\ compute-def-use must-infer
[ t ] [
[ 1 2 3 ] dataflow compute-def-use drop
[ 1 2 3 ] build-tree compute-def-use drop
def-use get {
[ assoc-size 3 = ]
[ values [ uses>> [ #return? ] all? ] all? ]
@ -29,5 +29,5 @@ IN: compiler.tree.def-use.tests
[ [ 1 ] [ call 2 ] curry call + ]
[ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ]
} [
[ ] swap [ dataflow compute-def-use drop ] curry unit-test
[ ] swap [ build-tree compute-def-use drop ] curry unit-test
] each

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

@ -28,6 +28,8 @@ TUPLE: definition value node uses ;
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 ;

40
unfinished/compiler/tree/dfa/backward/backward.factor Normal file
View File

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

40
unfinished/compiler/tree/dfa/dfa.factor Normal file
View File

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

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

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry kernel sequences assocs accessors namespaces
math.intervals arrays classes.algebra
math.intervals arrays classes.algebra locals
compiler.tree
compiler.tree.def-use
compiler.tree.propagation.info
@ -14,19 +14,28 @@ IN: compiler.tree.propagation.branches
GENERIC: child-constraints ( node -- seq )
M: #if child-constraints
in-d>> first
[ <true-constraint> ] [ <false-constraint> ] bi
2array ;
in-d>> first [ =t ] [ =f ] bi 2array ;
M: #dispatch child-constraints drop f ;
GENERIC: live-children ( #branch -- children )
M: #if live-children
[ children>> ] [ in-d>> first value-info possible-boolean-values ] bi
[ t swap memq? [ first ] [ drop f ] if ]
[ f swap memq? [ second ] [ drop f ] if ]
2bi 2array ;
M: #dispatch live-children
children>> ;
: infer-children ( node -- assocs )
[ children>> ] [ child-constraints ] bi [
[ live-children ] [ child-constraints ] bi [
[
value-infos [ clone ] change
constraints [ clone ] change
assume
(propagate)
[ first>> (propagate) ] when*
] H{ } make-assoc
] 2map ;
@ -37,13 +46,23 @@ M: #dispatch child-constraints drop f ;
[ swap (merge-value-infos) ] dip set-value-infos ;
: propagate-branch-phi ( results #phi -- )
[ nip node-defs-values [ introduce-value ] each ]
[ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
[ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
2tri ;
2bi ;
:: branch-phi-constraints ( x #phi -- )
#phi [ out-d>> ] [ phi-in-d>> ] bi [
first2 2dup and [ USE: prettyprint
[ [ =t x =t /\ ] [ =t x =f /\ ] bi* \/ swap t--> dup . assume ]
[ [ =f x =t /\ ] [ =f x =f /\ ] bi* \/ swap f--> dup . assume ]
3bi
] [ 3drop ] if
] 2each ;
: merge-children ( results node -- )
successor>> propagate-branch-phi ;
[ 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 ;

56
unfinished/compiler/tree/propagation/constraints/constraints.factor
View File

@ -2,7 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs math math.intervals kernel accessors
sequences namespaces disjoint-sets classes classes.algebra
combinators words compiler.tree compiler.tree.propagation.info ;
combinators words
compiler.tree compiler.tree.propagation.info
compiler.tree.copy-equiv ;
IN: compiler.tree.propagation.constraints
! A constraint is a statement about a value.
@ -12,12 +14,12 @@ SYMBOL: constraints
GENERIC: assume ( constraint -- )
GENERIC: satisfied? ( constraint -- ? )
GENERIC: satisfiable? ( constraint -- ? )
! Boolean constraints
TUPLE: true-constraint value ;
: <true-constraint> ( value -- constriant )
resolve-copy true-constraint boa ;
: =t ( value -- constriant ) resolve-copy true-constraint boa ;
M: true-constraint assume
[ constraints get at [ assume ] when* ]
@ -27,10 +29,12 @@ M: true-constraint assume
M: true-constraint satisfied?
value>> value-info class>> \ f class-not class<= ;
M: true-constraint satisfiable?
value>> value-info class>> \ f class-not classes-intersect? ;
TUPLE: false-constraint value ;
: <false-constraint> ( value -- constriant )
resolve-copy false-constraint boa ;
: =f ( value -- constriant ) resolve-copy false-constraint boa ;
M: false-constraint assume
[ constraints get at [ assume ] when* ]
@ -40,10 +44,13 @@ M: false-constraint assume
M: false-constraint satisfied?
value>> value-info class>> \ f class<= ;
M: false-constraint satisfiable?
value>> value-info class>> \ f classes-intersect? ;
! Class constraints
TUPLE: class-constraint value class ;
: <class-constraint> ( value class -- constraint )
: is-instance-of ( value class -- constraint )
[ resolve-copy ] dip class-constraint boa ;
M: class-constraint assume
@ -52,7 +59,7 @@ M: class-constraint assume
! Interval constraints
TUPLE: interval-constraint value interval ;
: <interval-constraint> ( value interval -- constraint )
: is-in-interval ( value interval -- constraint )
[ resolve-copy ] dip interval-constraint boa ;
M: interval-constraint assume
@ -61,7 +68,7 @@ M: interval-constraint assume
! Literal constraints
TUPLE: literal-constraint value literal ;
: <literal-constraint> ( value literal -- constraint )
: is-equal-to ( value literal -- constraint )
[ resolve-copy ] dip literal-constraint boa ;
M: literal-constraint assume
@ -70,29 +77,48 @@ M: literal-constraint assume
! Implication constraints
TUPLE: implication p q ;
C: <implication> implication
C: --> implication
M: implication assume
[ q>> ] [ p>> ] bi
[ constraints get set-at ]
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
M: implication satisfiable?
[ q>> satisfiable? ] [ p>> satisfiable? not ] bi or ;
! Conjunction constraints
TUPLE: conjunction p q ;
C: <conjunction> conjunction
C: /\ conjunction
M: conjunction assume [ p>> assume ] [ q>> assume ] bi ;
M: conjunction satisfiable?
[ p>> satisfiable? ] [ q>> satisfiable? ] bi and ;
! Disjunction constraints
TUPLE: disjunction p q ;
C: \/ disjunction
M: disjunction assume
{
{ [ dup p>> satisfiable? not ] [ q>> assume ] }
{ [ dup q>> satisfiable? not ] [ p>> assume ] }
[ drop ]
} cond ;
M: disjunction satisfiable?
[ p>> satisfiable? ] [ q>> satisfiable? ] bi or ;
! No-op
M: f assume drop ;
! Utilities
: if-true ( constraint boolean-value -- constraint' )
<true-constraint> swap <implication> ;
: t--> ( constraint boolean-value -- constraint' ) =t swap --> ;
: if-false ( constraint boolean-value -- constraint' )
<false-constraint> swap <implication> ;
: f--> ( constraint boolean-value -- constraint' ) =f swap --> ;
: <conditional> ( true-constr false-constr boolean-value -- constraint )
tuck [ if-true ] [ if-false ] 2bi* <conjunction> ;
tuck [ t--> ] [ f--> ] 2bi* /\ ;

4
unfinished/compiler/tree/propagation/info/info-tests.factor
View File

@ -2,6 +2,8 @@ USING: accessors math math.intervals sequences classes.algebra
math kernel tools.test compiler.tree.propagation.info ;
IN: compiler.tree.propagation.info.tests
[ f ] [ 0.0 -0.0 eql? ] unit-test
[ t ] [
number <class-info>
sequence <class-info>
@ -49,7 +51,7 @@ IN: compiler.tree.propagation.info.tests
value-info-intersect >literal<
] unit-test
[ T{ value-info f fixnum empty-interval f f } ] [
[ T{ value-info f null empty-interval f f } ] [
fixnum -10 0 [a,b] <class/interval-info>
fixnum 19 29 [a,b] <class/interval-info>
value-info-intersect

58
unfinished/compiler/tree/propagation/info/info.factor
View File

@ -1,26 +1,19 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra kernel accessors math
math.intervals namespaces disjoint-sets sequences words
combinators ;
math.intervals namespaces sequences words combinators arrays
compiler.tree.copy-equiv ;
IN: compiler.tree.propagation.info
SYMBOL: +interval+
GENERIC: eql? ( obj1 obj2 -- ? )
M: object eql? eq? ;
M: number eql? [ [ class ] bi@ = ] [ number= ] 2bi and ;
! Disjoint set of copy equivalence
SYMBOL: copies
: is-copy-of ( val copy -- ) copies get equate ;
: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
: resolve-copy ( copy -- val ) copies get representative ;
: introduce-value ( val -- ) copies get add-atom ;
M: fixnum eql? eq? ;
M: bignum eql? over bignum? [ = ] [ 2drop f ] if ;
M: ratio eql? over ratio? [ = ] [ 2drop f ] if ;
M: float eql? over float? [ [ double>bits ] bi@ = ] [ 2drop f ] if ;
M: complex eql? over complex? [ = ] [ 2drop f ] if ;
! Value info represents a set of objects. Don't mutate value infos
! you receive, always construct new ones. We don't declare the
@ -36,16 +29,18 @@ literal? ;
[ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
: interval>literal ( class interval -- literal literal? )
#! If interval has zero length and the class is sufficiently
#! precise, we can turn it into a literal
dup empty-interval eq? [
2drop f f
] [
dup from>> first {
{ [ over interval-length 0 > ] [ 3drop f f ] }
{ [ over from>> second not ] [ 3drop f f ] }
{ [ over to>> second not ] [ 3drop f f ] }
{ [ pick fixnum class<= ] [ 2nip >fixnum t ] }
{ [ pick bignum class<= ] [ 2nip >bignum t ] }
{ [ pick float class<= ] [ 2nip >float t ] }
{ [ pick integer class<= ] [ 2nip >fixnum t ] }
{ [ pick float class<= ] [
2nip dup zero? [ drop f f ] [ >float t ] if
] }
[ 3drop f f ]
} cond
] if ;
@ -53,13 +48,13 @@ literal? ;
: <value-info> ( class interval literal literal? -- info )
[
2nip
[ class ]
[ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ]
[ ]
tri t
[ class ] [ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ] [ ] tri
t
] [
drop
over null class<= [ drop empty-interval f f ] [
2dup [ null class<= ] [ empty-interval eq? ] bi* or [
2drop null empty-interval f f
] [
over integer class<= [ integral-closure ] when
2dup interval>literal
] if
@ -70,13 +65,14 @@ literal? ;
f f <value-info> ; foldable
: <class-info> ( class -- info )
[-inf,inf] <class/interval-info> ; foldable
dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or
<class/interval-info> ; foldable
: <interval-info> ( interval -- info )
real swap <class/interval-info> ; foldable
: <literal-info> ( literal -- info )
f [-inf,inf] rot t <value-info> ; foldable
f f rot t <value-info> ; foldable
: >literal< ( info -- literal literal? ) [ literal>> ] [ literal?>> ] bi ;
@ -122,3 +118,15 @@ SYMBOL: value-infos
: value-literal ( value -- obj ? )
value-info >literal< ;
: possible-boolean-values ( info -- values )
dup literal?>> [
literal>> 1array
] [
class>> {
{ [ dup null class<= ] [ { } ] }
{ [ dup \ f class-not class<= ] [ { t } ] }
{ [ dup \ f class<= ] [ { f } ] }
[ { t f } ]
} cond nip
] if ;

77
unfinished/compiler/tree/propagation/known-words/known-words.factor
View File

@ -1,23 +1,15 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel effects accessors math math.private math.libm
math.partial-dispatch math.intervals math.parser layouts words
sequences sequences.private arrays assocs classes
math.partial-dispatch math.intervals math.parser math.order
layouts words sequences sequences.private arrays assocs classes
classes.algebra combinators generic.math splitting fry locals
classes.tuple alien.accessors classes.tuple.private
compiler.tree.propagation.info compiler.tree.propagation.nodes
compiler.tree.propagation.constraints ;
compiler.tree.propagation.constraints
compiler.tree.comparisons ;
IN: compiler.tree.propagation.known-words
\ and [
[ [ <true-constraint> ] bi@ <conjunction> ] dip if-true
] +constraints+ set-word-prop
\ not [
[ [ <false-constraint> ] [ <true-constraint> ] bi ] dip
<conditional>
] +constraints+ set-word-prop
\ fixnum
most-negative-fixnum most-positive-fixnum [a,b]
+interval+ set-word-prop
@ -88,7 +80,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
] if ;
: binary-op-interval ( info1 info2 quot -- newinterval )
[ [ interval>> ] bi@ 2dup and ] dip [ 2drop f ] if ; inline
[ [ interval>> ] bi@ ] dip call ; inline
: won't-overflow? ( class interval -- ? )
[ fixnum class<= ] [ fixnum fits? ] bi* and ;
@ -148,36 +140,12 @@ most-negative-fixnum most-positive-fixnum [a,b]
\ bitor [ [ interval-bitor ] [ integer-valued ] binary-op ] each-derived-op
\ bitxor [ [ interval-bitxor ] [ integer-valued ] binary-op ] each-derived-op
: assume-interval ( i1 i2 op -- i3 )
{
{ \ < [ assume< ] }
{ \ > [ assume> ] }
{ \ <= [ assume<= ] }
{ \ >= [ assume>= ] }
} case ;
: swap-comparison ( op -- op' )
{
{ < > }
{ > < }
{ <= >= }
{ >= <= }
} at ;
: negate-comparison ( op -- op' )
{
{ < >= }
{ > <= }
{ <= > }
{ >= < }
} at ;
:: (comparison-constraints) ( in1 in2 op -- constraint )
[let | i1 [ in1 value-info interval>> ]
i2 [ in2 value-info interval>> ] |
in1 i1 i2 op assume-interval <interval-constraint>
in2 i2 i1 op swap-comparison assume-interval <interval-constraint>
<conjunction>
in1 i1 i2 op assumption is-in-interval
in2 i2 i1 op swap-comparison assumption is-in-interval
/\
] ;
: comparison-constraints ( in1 in2 out op -- constraint )
@ -187,10 +155,35 @@ most-negative-fixnum most-positive-fixnum [a,b]
3bi
] dip <conditional> ;
: comparison-op ( word op -- )
: define-comparison-constraints ( word op -- )
'[ , comparison-constraints ] +constraints+ set-word-prop ;
{ < > <= >= } [ dup [ comparison-op ] curry each-derived-op ] each
comparison-ops
[ dup '[ , define-comparison-constraints ] each-derived-op ] each
generic-comparison-ops [
dup specific-comparison
'[ , , define-comparison-constraints ] each-derived-op
] each
! Remove redundant comparisons
: fold-comparison ( info1 info2 word -- info )
[ [ interval>> ] bi@ ] dip interval-comparison {
{ incomparable [ object <class-info> ] }
{ t [ t <literal-info> ] }
{ f [ f <literal-info> ] }
} case ;
comparison-ops [
[
dup '[ , fold-comparison ] +outputs+ set-word-prop
] each-derived-op
] each
generic-comparison-ops [
dup specific-comparison
'[ , fold-comparison ] +outputs+ set-word-prop
] each
{
{ >fixnum fixnum }

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

@ -16,9 +16,6 @@ GENERIC: propagate-around ( node -- )
: (propagate) ( node -- )
[
[ node-defs-values [ introduce-value ] each ]
[ propagate-around ]
[ successor>> ]
tri
[ propagate-around ] [ successor>> ] bi
(propagate)
] when* ;

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

@ -1,5 +1,6 @@
USING: kernel compiler.frontend compiler.tree
compiler.tree.propagation tools.test math math.order
USING: kernel compiler.tree.builder compiler.tree
compiler.tree.propagation compiler.tree.copy-equiv
compiler.tree.def-use tools.test math math.order
accessors sequences arrays kernel.private vectors
alien.accessors alien.c-types ;
IN: compiler.tree.propagation.tests
@ -8,7 +9,11 @@ IN: compiler.tree.propagation.tests
\ propagate/node must-infer
: final-info ( quot -- seq )
dataflow propagate last-node node-input-infos ;
build-tree
compute-def-use
compute-copy-equiv
propagate
last-node node-input-infos ;
: final-classes ( quot -- seq )
final-info [ class>> ] map ;
@ -116,7 +121,7 @@ IN: compiler.tree.propagation.tests
[ V{ 9 } ] [
[
>fixnum
123 bitand
dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if
] final-literals
] unit-test
@ -143,3 +148,52 @@ IN: compiler.tree.propagation.tests
255 min 0 max
] final-classes
] unit-test
[ V{ fixnum } ] [
[ 0 dup 10 > [ 2 * ] when ] final-classes
] unit-test
[ V{ f } ] [
[ [ 0.0 ] [ -0.0 ] if ] final-literals
] unit-test
[ V{ 1.5 } ] [
[ /f 1.5 min 1.5 max ] final-literals
] unit-test
[ V{ 1.5 } ] [
[
/f
dup 1.5 <= [ dup 1.5 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
] final-literals
] unit-test
[ V{ 1.5 } ] [
[
/f
dup 1.5 <= [ dup 10 >= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
] final-literals
] unit-test
[ V{ f } ] [
[
/f
dup 0.0 < [ dup 0.0 > [ drop 0.0 ] unless ] [ drop 0.0 ] if
] final-literals
] unit-test
[ V{ fixnum } ] [
[ 0 dup 10 > [ 100 * ] when ] final-classes
] unit-test
[ V{ fixnum } ] [
[ 0 dup 10 > [ drop "foo" ] when ] final-classes
] unit-test
[ V{ fixnum } ] [
[ { fixnum } declare 3 3 - + ] final-classes
] unit-test
[ V{ t } ] [
[ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals
] unit-test

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

@ -1,7 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences namespaces hashtables
disjoint-sets
compiler.tree
compiler.tree.def-use
compiler.tree.propagation.info
@ -17,7 +16,6 @@ IN: compiler.tree.propagation
[
H{ } clone constraints set
>hashtable value-infos set
<disjoint-set> copies set
(propagate)
] with-scope ;

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

@ -8,6 +8,12 @@ compiler.tree.propagation.simple
compiler.tree.propagation.branches ;
IN: compiler.tree.propagation.recursive
! What if we reach a fixed point for the phi but not for the
! #call-label output?
! We need to compute scalar evolution so that sccp doesn't
! evaluate loops
: (merge-value-infos) ( inputs -- infos )
[ [ value-info ] map value-infos-union ] map ;
@ -22,11 +28,9 @@ IN: compiler.tree.propagation.recursive
M: #recursive propagate-around ( #recursive -- )
dup
[ children>> (propagate) ]
[ node-child propagate-recursive-phi ] bi
node-child
[ first>> (propagate) ] [ propagate-recursive-phi ] bi
[ drop ] [ propagate-around ] if ;
M: #call-recursive propagate-before ( #call-label -- )
#! What if we reach a fixed point for the phi but not for the
#! #call-label output?
[ label>> returns>> flip ] [ out-d>> ] bi merge-value-infos drop ;

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

@ -3,6 +3,7 @@
USING: fry accessors kernel sequences assocs words namespaces
classes.algebra combinators classes continuations
compiler.tree
compiler.tree.def-use
compiler.tree.propagation.info
compiler.tree.propagation.nodes
compiler.tree.propagation.constraints ;
@ -25,29 +26,12 @@ M: #push propagate-before
[ set-value-info ] 2each ;
M: #declare propagate-before
[ [ in-d>> ] [ out-d>> ] bi are-copies-of ]
[
[ declaration>> class-infos ] [ out-d>> ] bi
refine-value-infos
] bi ;
M: #shuffle propagate-before
[ out-d>> dup ] [ mapping>> ] bi
'[ , at ] map swap are-copies-of ;
M: #>r propagate-before
[ in-d>> ] [ out-r>> ] bi are-copies-of ;
M: #r> propagate-before
[ in-r>> ] [ out-d>> ] bi are-copies-of ;
M: #copy propagate-before
[ in-d>> ] [ out-d>> ] bi are-copies-of ;
declaration>> [ <class-info> swap refine-value-info ] assoc-each ;
: predicate-constraints ( value class boolean-value -- constraint )
[ [ <class-constraint> ] dip if-true ]
[ [ class-not <class-constraint> ] dip if-false ]
3bi <conjunction> ;
[ [ is-instance-of ] dip t--> ]
[ [ class-not is-instance-of ] dip f--> ]
3bi /\ ;
: custom-constraints ( #call quot -- )
[ [ in-d>> ] [ out-d>> ] bi append ] dip
@ -63,6 +47,24 @@ M: #copy propagate-before
] [ drop ] if
] if* ;
: call-outputs-quot ( node -- infos )
[ in-d>> [ value-info ] map ]
[ word>> +outputs+ word-prop ]
bi with-datastack ;
: foldable-call? ( #call -- ? )
dup word>> "foldable" word-prop [
in-d>> [ value-info literal?>> ] all?
] [
drop f
] if ;
: fold-call ( #call -- infos )
[ in-d>> [ value-info literal>> ] map ]
[ word>> [ execute ] curry ]
bi with-datastack
[ <literal-info> ] map ;
: default-output-value-infos ( node -- infos )
dup word>> "default-output-classes" word-prop [
class-infos
@ -70,12 +72,12 @@ M: #copy propagate-before
out-d>> length object <class-info> <repetition>
] ?if ;
: call-outputs-quot ( node quot -- infos )
[ in-d>> [ value-info ] map ] dip with-datastack ;
: output-value-infos ( node -- infos )
dup word>> +outputs+ word-prop
[ call-outputs-quot ] [ default-output-value-infos ] if* ;
{
{ [ dup foldable-call? ] [ fold-call ] }
{ [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] }
[ default-output-value-infos ]
} cond ;
M: #call propagate-before
[ [ output-value-infos ] [ out-d>> ] bi set-value-infos ]
@ -94,7 +96,10 @@ M: #call propagate-after
M: node propagate-after drop ;
: annotate-node ( node -- )
dup node-values [ dup value-info ] H{ } map>assoc >>info drop ;
dup
[ node-defs-values ] [ node-uses-values ] bi append
[ dup value-info ] H{ } map>assoc
>>info drop ;
M: node propagate-around
[ propagate-before ] [ annotate-node ] [ propagate-after ] tri ;

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

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic assocs kernel math namespaces parser
sequences words vectors math.intervals effects classes
accessors combinators stack-checker.state ;
accessors combinators stack-checker.state stack-checker.visitor ;
IN: compiler.tree
! High-level tree SSA form.
@ -16,20 +16,12 @@ IN: compiler.tree
! 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
history successor children ;
successor children ;
M: node hashcode* drop node hashcode* ;
: node-shuffle ( node -- shuffle )
[ in-d>> ] [ out-d>> ] bi <effect> ;
: node-values ( node -- values )
{ [ in-d>> ] [ out-d>> ] [ in-r>> ] [ out-r>> ] } cleave
4array concat ;
: node-child ( node -- child ) children>> first ;
: last-node ( node -- last )
@ -57,7 +49,7 @@ TUPLE: #introduce < node values ;
: #introduce ( values -- node )
\ #introduce new swap >>values ;
TUPLE: #call < node word ;
TUPLE: #call < node word history ;
: #call ( inputs outputs word -- node )
\ #call new
@ -137,11 +129,9 @@ TUPLE: #phi < node phi-in-d phi-in-r ;
TUPLE: #declare < node declaration ;
: #declare ( inputs outputs declaration -- node )
: #declare ( declaration -- node )
\ #declare new
swap >>declaration
swap >>out-d
swap >>in-d ;
swap >>declaration ;
TUPLE: #return < node label ;
@ -172,3 +162,30 @@ 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 #call-recursive, #call-recursive 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 #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, ;

50
unfinished/compiler/tree/untupling/untupling-tests.factor Normal file
View File

@ -0,0 +1,50 @@
IN: compiler.tree.untupling.tests
USING: assocs math kernel quotations.private slots.private
compiler.tree.builder
compiler.tree.def-use
compiler.tree.copy-equiv
compiler.tree.untupling
tools.test ;
: check-untupling ( quot -- sizes )
build-tree
compute-copy-equiv
compute-def-use
compute-untupling
values ;
[ { } ] [ [ 1 [ + ] curry ] check-untupling ] unit-test
[ { 2 } ] [ [ 1 [ + ] curry drop ] check-untupling ] unit-test
[ { 2 } ] [ [ 1 [ + ] curry 3 slot ] check-untupling ] unit-test
[ { 2 } ] [ [ 1 [ + ] curry 3 slot drop ] check-untupling ] unit-test
[ { 2 } ] [ [ 1 [ + ] curry uncurry ] check-untupling ] unit-test
[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
[ { 2 } ] [ [ 2 1 [ + ] curry call ] check-untupling ] unit-test
[ { } ] [ [ [ 1 [ + ] curry ] [ [ ] ] if ] check-untupling ] unit-test
[ { 2 2 } ] [
[ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if uncurry ] check-untupling
] unit-test
[ { } ] [
[ [ 1 [ + ] curry ] [ 2 [ * ] curry ] if ] check-untupling
] unit-test
[ { 2 2 2 } ] [
[ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if uncurry ] check-untupling
] unit-test
[ { 2 2 } ] [
[ [ 1 [ + ] curry 4 ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if uncurry ] if ] check-untupling
] unit-test
[ { } ] [
[ [ 1 [ + ] curry ] [ dup [ 2 [ * ] curry ] [ 3 [ / ] curry ] if ] if ] check-untupling
] unit-test

59
unfinished/compiler/tree/untupling/untupling.factor Normal file
View File

@ -0,0 +1,59 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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 ;
IN: compiler.tree.untupling
SYMBOL: escaping-values
: mark-escaping-values ( node -- )
in-d>> escaping-values get '[ resolve-copy , conjoin ] each ;
SYMBOL: untupling-candidates
: untupling-candidate ( #call class -- )
#! 1- for delegate
size>> 1- swap out-d>> first resolve-copy
untupling-candidates get set-at ;
GENERIC: compute-untupling* ( node -- )
M: #call compute-untupling*
dup word>> {
{ \ <tuple-boa> [ dup in-d>> peek untupling-candidate ] }
{ \ curry [ \ curry tuple-layout untupling-candidate ] }
{ \ compose [ \ compose tuple-layout untupling-candidate ] }
{ \ slot [ drop ] }
[ drop mark-escaping-values ]
} case ;
M: #return compute-untupling*
dup label>> [ drop ] [ mark-escaping-values ] if ;
M: node compute-untupling* drop ;
GENERIC: check-consistency* ( node -- )
: check-value-consistency ( out-value in-values -- )
swap escaping-values get key? [
escaping-values get '[ , conjoin ] each
] [
untupling-candidates get 2dup '[ , at ] map all-equal?
[ 2drop ] [ '[ , delete-at ] each ] if
] if ;
M: #phi check-consistency*
[ [ out-d>> ] [ phi-in-d>> ] bi [ check-value-consistency ] 2each ]
[ [ out-r>> ] [ phi-in-r>> ] bi [ check-value-consistency ] 2each ]
bi ;
M: node check-consistency* drop ;
: compute-untupling ( node -- assoc )
H{ } clone escaping-values set
H{ } clone untupling-candidates set
[ [ compute-untupling* ] each-node ]
[ [ check-consistency* ] each-node ] bi
untupling-candidates get escaping-values get assoc-diff ;

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

@ -176,7 +176,7 @@ M: object apply-object push-literal ;
[
init-inference
init-known-values
dataflow-visitor off
stack-visitor off
dependencies off
[ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
[ finish-word current-effect ]
@ -202,10 +202,10 @@ M: object apply-object push-literal ;
V{ } clone recorded set
init-inference
init-known-values
dataflow-visitor off
stack-visitor off
call
end-infer
current-effect
dataflow-visitor get
stack-visitor get
] [ ] [ undo-infer ] cleanup
] with-scope ; inline

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

@ -65,7 +65,7 @@ SYMBOL: quotations
: infer-branches ( branches -- input children data )
[ pop-d ] dip
[ infer-branch ] map
[ dataflow-visitor branch-variable ] keep ;
[ stack-visitor branch-variable ] keep ;
: (infer-if) ( branches -- )
infer-branches [ first2 #if, ] dip compute-phi-function ;

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

@ -81,7 +81,7 @@ SYMBOL: phi-out
dup recursive-word-inputs
meta-d get
dataflow-visitor get
stack-visitor get
] with-scope ;
: inline-recursive-word ( word -- )

2
unfinished/stack-checker/known-words/known-words.factor
View File

@ -52,7 +52,7 @@ IN: stack-checker.known-words
: infer-declare ( -- )
pop-literal nip
[ length consume-d dup copy-values dup output-d ] keep
[ length ensure-d ] keep zip
#declare, ;
GENERIC: infer-call* ( value known -- )

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

@ -16,7 +16,7 @@ M: f #terminate, ;
M: f #if, 3drop ;
M: f #dispatch, 2drop ;
M: f #phi, 2drop 2drop ;
M: f #declare, 3drop ;
M: f #declare, drop ;
M: f #recursive, drop drop drop drop drop ;
M: f #copy, 2drop ;
M: f #drop, drop ;

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

@ -3,25 +3,25 @@
USING: kernel arrays namespaces ;
IN: stack-checker.visitor
SYMBOL: dataflow-visitor
SYMBOL: stack-visitor
HOOK: child-visitor dataflow-visitor ( -- visitor )
HOOK: child-visitor stack-visitor ( -- visitor )
: nest-visitor ( -- ) child-visitor dataflow-visitor set ;
: nest-visitor ( -- ) child-visitor stack-visitor set ;
HOOK: #introduce, dataflow-visitor ( values -- )
HOOK: #call, dataflow-visitor ( inputs outputs word -- )
HOOK: #call-recursive, dataflow-visitor ( inputs outputs word -- )
HOOK: #push, dataflow-visitor ( literal value -- )
HOOK: #shuffle, dataflow-visitor ( inputs outputs mapping -- )
HOOK: #drop, dataflow-visitor ( values -- )
HOOK: #>r, dataflow-visitor ( inputs outputs -- )
HOOK: #r>, dataflow-visitor ( inputs outputs -- )
HOOK: #terminate, dataflow-visitor ( -- )
HOOK: #if, dataflow-visitor ( ? true false -- )
HOOK: #dispatch, dataflow-visitor ( n branches -- )
HOOK: #phi, dataflow-visitor ( d-phi-in d-phi-out r-phi-in r-phi-out -- )
HOOK: #declare, dataflow-visitor ( inputs outputs declaration -- )
HOOK: #return, dataflow-visitor ( label stack -- )
HOOK: #recursive, dataflow-visitor ( word label inputs outputs visitor -- )
HOOK: #copy, dataflow-visitor ( inputs outputs -- )
HOOK: #introduce, stack-visitor ( values -- )
HOOK: #call, stack-visitor ( inputs outputs word -- )
HOOK: #call-recursive, stack-visitor ( inputs outputs word -- )
HOOK: #push, stack-visitor ( literal value -- )
HOOK: #shuffle, stack-visitor ( inputs outputs mapping -- )
HOOK: #drop, stack-visitor ( values -- )
HOOK: #>r, stack-visitor ( inputs outputs -- )
HOOK: #r>, stack-visitor ( inputs outputs -- )
HOOK: #terminate, stack-visitor ( -- )
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: #declare, stack-visitor ( declaration -- )
HOOK: #return, stack-visitor ( label stack -- )
HOOK: #recursive, stack-visitor ( word label inputs outputs visitor -- )
HOOK: #copy, stack-visitor ( inputs outputs -- )