+++ /dev/null
-USING: help.markup help.syntax sequences quotations words
-compiler.tree stack-checker.errors ;
-IN: compiler.frontend
-
-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."
-$nl
-"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is either a sequence of classes, or a sequence of sequences of classes. Each element in the sequence (or the sequence itself, in the former case) is a specialization hint."
-$nl
-"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
-$nl
-"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
-$nl
-"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class."
-$nl
-"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
-{ $code
-"\\ append"
-"{ { string string } { array array } }"
-"\"specializer\" set-word-prop"
-}
-"The specialized version of a word which will be compiled by the compiler can be inspected:"
-{ $subsection specialized-def } ;
-
-HELP: dataflow
-{ $values { "quot" quotation } { "dataflow" node } }
-{ $description "Attempts to construct a dataflow graph showing stack flow in the quotation." }
-{ $notes "This is the first stage of the compiler." }
-{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
-
-HELP: dataflow-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." }
-{ $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ;
-
-HELP: specialized-def
-{ $values { "word" word } { "quot" quotation } }
-{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;
+++ /dev/null
-IN: compiler.frontend.tests
-USING: compiler.frontend tools.test ;
-
-\ dataflow must-infer
-\ dataflow-with must-infer
-\ word-dataflow must-infer
+++ /dev/null
-! 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 ;
--- /dev/null
+USING: help.markup help.syntax sequences quotations words
+compiler.tree stack-checker.errors ;
+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."
+$nl
+"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is either a sequence of classes, or a sequence of sequences of classes. Each element in the sequence (or the sequence itself, in the former case) is a specialization hint."
+$nl
+"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
+$nl
+"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
+$nl
+"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class."
+$nl
+"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
+{ $code
+"\\ append"
+"{ { string string } { array array } }"
+"\"specializer\" set-word-prop"
+}
+"The specialized version of a word which will be compiled by the compiler can be inspected:"
+{ $subsection specialized-def } ;
+
+HELP: build-tree
+{ $values { "quot" quotation } { "dataflow" node } }
+{ $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: build-tree-with
+{ $values { "quot" quotation } { "stack" sequence } { "dataflow" node } }
+{ $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
+{ $values { "word" word } { "quot" quotation } }
+{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;
--- /dev/null
+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
! 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 ;
-
-: node, ( node -- )
- dataflow-visitor get swap
- over last>>
- [ [ [ last>> ] dip >>successor drop ] [ >>last drop ] 2bi ]
- [ [ >>first ] [ >>last ] bi drop ]
- if ;
-
-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, ;
+: with-tree-builder ( quot -- dataflow )
+ [ node-list new stack-visitor set ] prepose
+ with-infer first>> ; inline
+
+GENERIC# build-tree-with 1 ( quot stack -- dataflow )
+
+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 ;
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
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 ;
: (each-node) ( quot -- next )
node@ [ swap call ] 2keep
- node-children [
- [
+ children>> [
+ first>> [
[ (each-node) ] keep swap
] iterate-nodes
] each drop
] 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 [
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
-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 ;
\ remove-dead-code must-infer
: count-live-values ( quot -- n )
- dataflow
+ build-tree
compute-def-use
remove-dead-code
compute-def-use
! 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 -- )
-
-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 ;
+SYMBOL: live-values
-: 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
: 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 ;
[ 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
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*
- [ in-d>> empty? ] prune-if ;
+M: #shuffle remove-dead-nodes* dup in-d>> prune-if-empty ;
-M: #push remove-dead-nodes*
- [ out-d>> empty? ] prune-if ;
+M: #push remove-dead-nodes* dup out-d>> prune-if-empty ;
-M: #>r remove-dead-nodes*
- [ in-d>> empty? ] prune-if ;
+M: #>r remove-dead-nodes* dup in-d>> prune-if-empty ;
-M: #r> remove-dead-nodes*
- [ in-r>> empty? ] prune-if ;
+M: #r> remove-dead-nodes* dup in-r>> prune-if-empty ;
-M: node remove-dead-nodes* drop t ;
+M: #copy remove-dead-nodes* dup in-d>> prune-if-empty ;
: (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 ;
+ 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 ;
+
+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 ;
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? ]
[ [ 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
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 ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: compiler.tree.dfa.backward
+USING: accessors sequences assocs kernel compiler.tree
+compiler.tree.dfa ;
+
+GENERIC: backward ( value node -- )
+
+M: #copy backward
+ #! If the output of a copy is live, then the corresponding
+ #! input is live also.
+ [ out-d>> index ] keep in-d>> nth look-at-value ;
+
+M: #call backward
+ #! If any of the outputs of a call are live, then all
+ #! inputs and outputs must be live.
+ nip [ look-at-inputs ] [ look-at-outputs ] bi ;
+
+M: #call-recursive backward
+ #! If the output of a copy is live, then the corresponding
+ #! inputs to #return nodes are live also.
+ [ out-d>> <reversed> index ] keep label>> returns>>
+ [ <reversed> nth look-at-value ] with each ;
+
+M: #>r backward nip in-d>> first look-at-value ;
+
+M: #r> backward nip in-r>> first look-at-value ;
+
+M: #shuffle backward mapping>> at look-at-value ;
+
+M: #phi backward
+ #! If any of the outputs of a #phi are live, then the
+ #! corresponding inputs are live too.
+ [ [ out-d>> ] [ phi-in-d>> ] bi look-at-corresponding ]
+ [ [ out-r>> ] [ phi-in-r>> ] bi look-at-corresponding ]
+ 2bi ;
+
+M: node backward 2drop ;
+
+: backward-dfa ( node quot -- assoc ) [ backward ] dfa ; inline
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: fry accessors namespaces assocs dequeues search-dequeues
+kernel sequences words sets stack-checker.inlining compiler.tree
+compiler.tree.def-use compiler.tree.combinators ;
+IN: compiler.tree.dfa
+
+! Dataflow analysis
+SYMBOL: work-list
+
+: look-at-value ( values -- )
+ work-list get push-front ;
+
+: look-at-values ( values -- )
+ work-list get '[ , push-front ] each ;
+
+: look-at-inputs ( node -- ) in-d>> look-at-values ;
+
+: look-at-outputs ( node -- ) out-d>> look-at-values ;
+
+: look-at-corresponding ( value inputs outputs -- )
+ [ index ] dip over [ nth look-at-values ] [ 2drop ] if ;
+
+: init-dfa ( -- )
+ #! We add f initially because #phi nodes can have f in their
+ #! inputs.
+ <hashed-dlist> work-list set ;
+
+: iterate-dfa ( value assoc quot -- )
+ 2over key? [
+ 3drop
+ ] [
+ [ dupd conjoin dup defined-by ] dip call
+ ] if ; inline
+
+: dfa ( node mark-quot iterate-quot -- assoc )
+ init-dfa
+ [ each-node ] dip
+ work-list get H{ { f f } } clone
+ [ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline
! 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
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 ;
[ 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 ;
! 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.
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* ]
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* ]
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
! 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
! 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
! 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* /\ ;
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>
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
! 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
[ +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 ;
: <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
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 ;
: 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 ;
! 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
] 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 ;
\ 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 )
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 }
: (propagate) ( node -- )
[
- [ node-defs-values [ introduce-value ] each ]
- [ propagate-around ]
- [ successor>> ]
- tri
+ [ propagate-around ] [ successor>> ] bi
(propagate)
] when* ;
-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
\ 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 ;
[ V{ 9 } ] [
[
- >fixnum
+ 123 bitand
dup 10 < [ dup 8 > [ drop 9 ] unless ] [ drop 9 ] if
] final-literals
] unit-test
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
! 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
[
H{ } clone constraints set
>hashtable value-infos set
- <disjoint-set> copies set
(propagate)
] with-scope ;
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 ;
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 ;
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 ;
[ 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
] [ 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
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 ]
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 ;
! 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.
! 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 )
: #introduce ( values -- node )
\ #introduce new swap >>values ;
-TUPLE: #call < node word ;
+TUPLE: #call < node word history ;
: #call ( inputs outputs word -- node )
\ #call new
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 ;
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, ;
--- /dev/null
+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
--- /dev/null
+! 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 ;
[
init-inference
init-known-values
- dataflow-visitor off
+ stack-visitor off
dependencies off
[ [ def>> ] [ ] [ ] tri infer-quot-recursive end-infer ]
[ finish-word current-effect ]
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
: 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 ;
dup recursive-word-inputs
meta-d get
- dataflow-visitor get
+ stack-visitor get
] with-scope ;
: inline-recursive-word ( word -- )
: 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 -- )
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 ;
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 -- )
projects / factor.git / commitdiff