Working on sparse conditional constant propagation and untupling
parent
ef1e8ee8f6
commit
972619f50f
|
@ -1,6 +0,0 @@
|
|||
IN: compiler.frontend.tests
|
||||
USING: compiler.frontend tools.test ;
|
||||
|
||||
\ dataflow must-infer
|
||||
\ dataflow-with must-infer
|
||||
\ word-dataflow must-infer
|
|
@ -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 ;
|
|
@ -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
|
|
@ -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
|
|
@ -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 ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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 [
|
||||
|
|
|
@ -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 ;
|
|
@ -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 ;
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -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 ;
|
||||
|
|
|
@ -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* /\ ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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* ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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, ;
|
||||
|
|
|
@ -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
|
|
@ -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 ;
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
Loading…
Reference in New Issue