INSTANCE: column virtual-sequence
: <flipped> ( seq -- seq' )
- dup empty? [ first length [ <column> ] with map ] unless ;
+ dup empty? [ dup first length [ <column> ] with map ] unless ;
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces arrays sequences io debugger words
+USING: kernel namespaces arrays sequences io debugger words fry
compiler.units continuations vocabs assocs dlists definitions
math threads graphs generic combinators dequeues search-dequeues
stack-checker stack-checker.state compiler.generator
: (compile) ( word -- )
USE: prettyprint dup .
- [
+ '[
H{ } clone dependencies set
- {
+ , {
[ compile-begins ]
[
[ build-tree-from-word ] [ compile-failed return ] recover
[ dup generate ]
[ compile-succeeded ]
} cleave
- ] curry with-return ;
+ ] with-return ;
: compile-loop ( dequeue -- )
[ (compile) yield ] slurp-dequeue ;
%jump-label ;
: generate-call ( label -- next )
- dup maybe-compile
+ ! dup maybe-compile
end-basic-block
dup compiling-loops get at [
%jump-label f
] ?if ;
! #recursive
-: compile-recursive ( node -- )
+: compile-recursive ( node -- next )
dup label>> id>> generate-call >r
[ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
r> ;
: compiling-loop ( word -- )
<label> dup resolve-label swap compiling-loops get set-at ;
-: compile-loop ( node -- )
+: compile-loop ( node -- next )
end-basic-block
[ label>> id>> compiling-loop ] [ child>> generate-nodes ] bi
iterate-next ;
] if ;
M: #call generate-node
- dup node-input-infos [ class>> ] map set-operand-classes
+ ! dup node-input-infos [ class>> ] map set-operand-classes
dup find-if-intrinsic [
do-if-intrinsic
] [
IN: compiler.tree.builder.tests
-USING: compiler.tree.builder tools.test ;
+USING: compiler.tree.builder tools.test sequences kernel
+compiler.tree ;
\ build-tree must-infer
\ build-tree-with must-infer
\ build-tree-from-word must-infer
+
+: inline-recursive ( -- ) inline-recursive ; inline recursive
+
+[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] contains? nip ] unit-test
] with-tree-builder nip
unclip-last in-d>> ;
+: ends-with-terminate? ( nodes -- ? )
+ dup empty? [ drop f ] [ peek #terminate? ] if ;
+
: build-sub-tree ( #call quot -- nodes )
- [ [ out-d>> ] [ in-d>> ] bi ] dip
- build-tree-with
- rot #copy suffix ;
+ [ [ out-d>> ] [ in-d>> ] bi ] dip build-tree-with
+ over ends-with-terminate?
+ [ drop swap [ f swap #push ] map append ]
+ [ rot #copy suffix ]
+ if ;
: (make-specializer) ( class picker -- quot )
swap "predicate" word-prop append ;
[ drop ]
} cond ;
+: (build-tree-from-word) ( word -- )
+ dup
+ [ "inline" word-prop ]
+ [ "recursive" word-prop ] bi and [
+ 1quotation f infer-quot
+ ] [
+ [ specialized-def ]
+ [ dup 2array 1array ] bi infer-quot
+ ] if ;
+
+: check-cannot-infer ( word -- )
+ dup +cannot-infer+ word-prop [ cannot-infer-effect ] [ drop ] if ;
+
+: check-no-compile ( word -- )
+ dup "no-compile" word-prop [ cannot-infer-effect ] [ drop ] if ;
+
: build-tree-from-word ( word -- effect nodes )
[
[
- 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
+ {
+ [ check-cannot-infer ]
+ [ check-no-compile ]
+ [ (build-tree-from-word) ]
+ [ finish-word ]
+ } cleave
] maybe-cannot-infer
] with-tree-builder ;
! A phase run after propagation to finish the job, so to speak.
! Codifies speculative inlining decisions, deletes branches
! marked as never taken, and flattens local recursive blocks
-! that do not call themselves.
+! that do not call themselves. Finally, if inlining inserts a
+! #terminate, we delete all nodes after that.
+
+GENERIC: delete-node ( node -- )
+
+M: #call-recursive delete-node
+ dup label>> [ [ eq? not ] with filter ] change-calls drop ;
+
+M: #return-recursive delete-node
+ label>> f >>return drop ;
+
+M: node delete-node drop ;
+
+: delete-nodes ( nodes -- ) [ delete-node ] each-node ;
GENERIC: cleanup* ( node -- node/nodes )
+: termination-cleanup ( nodes -- nodes' )
+ dup [ #terminate? ] find drop [ 1+ cut delete-nodes ] when* ;
+
: cleanup ( nodes -- nodes' )
#! We don't recurse into children here, instead the methods
#! do it since the logic is a bit more involved
- [ cleanup* ] map flatten ;
+ [ cleanup* ] map flatten ; ! termination-cleanup ;
: cleanup-folding? ( #call -- ? )
node-output-infos dup empty?
M: #declare cleanup* drop f ;
-GENERIC: delete-node ( node -- )
-
-M: #call-recursive delete-node
- dup label>> [ [ eq? not ] with filter ] change-calls drop ;
-
-M: #return-recursive delete-node
- label>> f >>return drop ;
-
-M: node delete-node drop ;
-
-: delete-nodes ( nodes -- ) [ delete-node ] each-node ;
-
: delete-unreachable-branches ( #branch -- )
dup live-branches>> '[
,
[ [ out-r>> ] [ phi-in-r>> ] bi look-at-phi ]
2bi ;
-SYMBOL: if-node
-
-M: #if remove-dead-code*
- [ [ (remove-dead-code) ] map ] change-children
- dup if-node set ;
+M: #branch remove-dead-code*
+ [ [ (remove-dead-code) ] map ] change-children ;
: remove-phi-inputs ( #phi -- )
- dup [ out-d>> ] [ phi-in-d>> ] bi filter-corresponding >>phi-in-d
- dup [ out-r>> ] [ phi-in-r>> ] bi filter-corresponding >>phi-in-r
+ dup [ out-d>> ] [ phi-in-d>> flip ] bi filter-corresponding flip >>phi-in-d
+ dup [ out-r>> ] [ phi-in-r>> flip ] bi filter-corresponding flip >>phi-in-r
drop ;
-: dead-value-indices ( values -- indices )
- [ length ] keep live-values get
- '[ , nth , key? not ] filter ; inline
-
-: drop-d-values ( values indices -- node )
- [ drop filter-live ] [ nths filter-live ] 2bi
- [ make-values ] keep
- [ drop ] [ zip ] 2bi
- #shuffle ;
-
-: drop-r-values ( values indices -- nodes )
- [ dup make-values [ #r> ] keep ] dip
- drop-d-values dup out-d>> dup make-values #>r
- 3array ;
-
-: insert-drops ( nodes d-values r-values d-indices r-indices -- nodes' )
- '[
- [ , drop-d-values 1array ]
- [ , drop-r-values ]
- bi* 3append
- ] 3map ;
-
-: hoist-drops ( #phi -- )
- if-node get swap
- {
- [ phi-in-d>> ]
- [ phi-in-r>> ]
- [ out-d>> dead-value-indices ]
- [ out-r>> dead-value-indices ]
- } cleave
- '[ , , , , insert-drops ] change-children drop ;
+! SYMBOL: if-node
+!
+! : dead-value-indices ( values -- indices )
+! [ length ] keep live-values get
+! '[ , nth , key? not ] filter ; inline
+!
+! : drop-d-values ( values indices -- node )
+! [ drop filter-live ] [ nths filter-live ] 2bi
+! [ make-values ] keep
+! [ drop ] [ zip ] 2bi
+! #shuffle ;
+!
+! : drop-r-values ( values indices -- nodes )
+! [ dup make-values [ #r> ] keep ] dip
+! drop-d-values dup out-d>> dup make-values #>r
+! 3array ;
+!
+! : insert-drops ( nodes d-values r-values d-indices r-indices -- nodes' )
+! '[
+! [ , drop-d-values 1array ]
+! [ , drop-r-values ]
+! bi* 3append
+! ] 3map ;
+!
+! : hoist-drops ( #phi -- )
+! if-node get swap
+! {
+! [ phi-in-d>> ]
+! [ phi-in-r>> ]
+! [ out-d>> dead-value-indices ]
+! [ out-r>> dead-value-indices ]
+! } cleave
+! '[ , , , , insert-drops ] change-children drop ;
: remove-phi-outputs ( #phi -- )
[ filter-live ] change-out-d
M: #phi remove-dead-code*
{
- [ hoist-drops ]
+ ! [ hoist-drops ]
[ remove-phi-inputs ]
[ remove-phi-outputs ]
[ ]
USING: namespaces assocs sequences compiler.tree.builder
compiler.tree.dead-code compiler.tree.def-use compiler.tree
-compiler.tree.combinators compiler.tree.debugger
+compiler.tree.combinators compiler.tree.propagation
+compiler.tree.cleanup compiler.tree.escape-analysis
+compiler.tree.tuple-unboxing compiler.tree.debugger
compiler.tree.normalization compiler.tree.checker tools.test
kernel math stack-checker.state accessors combinators io ;
IN: compiler.tree.dead-code.tests
: count-live-values ( quot -- n )
build-tree
normalize
+ propagate
+ cleanup
+ escape-analysis
+ unbox-tuples
compute-def-use
remove-dead-code
0 swap [
[ 2 ] [ [ [ 1 ] [ dup ] if drop ] count-live-values ] unit-test
-[ 2 ] [ [ 1 2 + ] count-live-values ] unit-test
+[ 2 ] [ [ 1 + ] count-live-values ] unit-test
[ 0 ] [ [ 1 2 + drop ] count-live-values ] unit-test
-[ 3 ] [ [ 1 2 + 3 + ] count-live-values ] unit-test
+[ 3 ] [ [ 1 + 3 + ] count-live-values ] unit-test
[ 0 ] [ [ 1 2 + 3 + drop ] count-live-values ] unit-test
[ 0 ] [ [ [ 1 ] [ 2 ] compose call + drop ] count-live-values ] unit-test
+[ 3 ] [ [ 10 [ ] times ] count-live-values ] unit-test
+
: optimize-quot ( quot -- quot' )
- build-tree normalize compute-def-use remove-dead-code
- dup check-nodes nodes>quot ;
+ build-tree
+ normalize
+ propagate
+ cleanup
+ escape-analysis
+ unbox-tuples
+ compute-def-use
+ remove-dead-code
+ "no-check" get [ dup check-nodes ] unless nodes>quot ;
[ [ drop 1 ] ] [ [ >r 1 r> drop ] optimize-quot ] unit-test
[ [ [ drop drop ] [ non-flushable-3 drop ] if ] ] [
[ [ flushable-1 ] [ non-flushable-3 ] if drop ] optimize-quot
] unit-test
+
+[ [ [ f ] [ f ] if ] ] [ [ [ f ] [ f ] if ] optimize-quot ] unit-test
+
+[ ] [ [ dup [ 3 throw ] [ ] if ] optimize-quot drop ] unit-test
+
+: non-flushable-4 ( a -- b ) drop f ;
+
+: recursive-test-1 ( a b -- )
+ dup 10 < [
+ >r drop 5 non-flushable-4 r> 1 + recursive-test-1
+ ] [ 2drop ] if ; inline recursive
M: #return-recursive compute-live-values*
[ out-d>> ] [ return-recursive-phi-in ] bi look-at-phi ;
+M: #call-recursive compute-live-values*
+ #! If the output of a copy is live, then the corresponding
+ #! inputs to #return nodes are live also.
+ [ out-d>> ] [ label>> return>> in-d>> ] bi look-at-mapping ;
+
M: #recursive remove-dead-code*
- [ filter-live ] change-in-d ;
+ [ filter-live ] change-in-d
+ [ (remove-dead-code) ] change-child ;
M: #call-recursive remove-dead-code*
[ filter-live ] change-in-d
M: #call compute-live-values* nip look-at-inputs ;
-M: #call-recursive compute-live-values*
- #! If the output of a copy is live, then the corresponding
- #! inputs to #return nodes are live also.
- [ out-d>> ] [ label>> return>> ] bi look-at-mapping ;
-
M: #>r compute-live-values*
[ out-r>> ] [ in-d>> ] bi look-at-mapping ;
[ in-d>> ] [ out-d>> ] bi
2dup swap zip #shuffle
remove-dead-code* ;
+
+M: #terminate remove-dead-code*
+ [ filter-live ] change-in-d
+ [ filter-live ] change-in-r ;
MATCH-VARS: ?a ?b ?c ;
: pretty-shuffle ( effect -- word/f )
- [ in>> ] [ out>> ] bi drop-prefix [ >array ] bi@ 2array {
+ [ in>> ] [ out>> ] bi 2array {
{ { { } { } } [ ] }
{ { { ?a } { ?a } } [ ] }
{ { { ?a ?b } { ?a ?b } } [ ] }
[ in-r>> length ] [ out-d>> empty? \ rdrop \ r> ? ] bi
<repetition> % ;
+M: #alien-invoke node>quot params>> , \ #alien-invoke , ;
+
+M: #alien-indirect node>quot params>> , \ #alien-indirect , ;
+
+M: #alien-callback node>quot params>> , \ #alien-callback , ;
+
M: node node>quot drop ;
: nodes>quot ( node -- quot )
[ phi-in-d>> ] [ phi-in-r>> ] bi
append concat remove-bottom prune ;
M: #declare node-uses-values declaration>> keys ;
+M: #terminate node-uses-values [ in-d>> ] [ in-r>> ] bi append ;
+M: #alien-callback node-uses-values drop f ;
M: node node-uses-values in-d>> ;
GENERIC: node-defs-values ( node -- values )
M: #return node-defs-values drop f ;
M: #recursive node-defs-values drop f ;
M: #terminate node-defs-values drop f ;
+M: #alien-callback node-defs-values drop f ;
M: node node-defs-values out-d>> ;
: node-def-use ( node -- )
M: #alien-invoke escape-analysis*
[ in-d>> add-escaping-values ]
- [ out-d>> unknown-allocation ]
+ [ out-d>> unknown-allocations ]
bi ;
M: #alien-indirect escape-analysis*
[ in-d>> add-escaping-values ]
- [ out-d>> unknown-allocation ]
+ [ out-d>> unknown-allocations ]
bi ;
compiler.tree.strength-reduction
compiler.tree.loop.detection
compiler.tree.loop.inversion
-compiler.tree.branch-fusion ;
+compiler.tree.branch-fusion
+compiler.tree.checker ;
IN: compiler.tree.optimizer
: optimize-tree ( nodes -- nodes' )
propagate
cleanup
detect-loops
- invert-loops
- fuse-branches
- escape-analysis
- unbox-tuples
- compute-def-use
- remove-dead-code
- strength-reduce ;
+ ! invert-loops
+ ! fuse-branches
+ ! escape-analysis
+ ! unbox-tuples
+ ! compute-def-use
+ ! remove-dead-code
+ ! strength-reduce
+ compute-def-use USE: kernel
+ dup check-nodes ;
SYMBOL: history
: remember-inlining ( word -- )
- history get [ swap suffix ] change ;
+ history [ swap suffix ] change ;
: inline-word ( #call word -- )
dup history get memq? [
{ <tuple> <tuple-boa> } [
[
- literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if
+ literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
[ clear ] dip
] +outputs+ set-word-prop
] each
\ instance? [
[ value-info ] dip over literal>> class? [
[ literal>> ] dip predicate-constraints
- ] [ 2drop f ] if
+ ] [ 3drop f ] if
] +constraints+ set-word-prop
\ instance? [
dup literal>> class?
- [ literal>> predicate-output-infos ] [ 2drop f ] if
+ [ literal>> predicate-output-infos ] [ 2drop object-info ] if
] +outputs+ set-word-prop
0 10 [ bad-generic dup 123 bitand drop bad-generic 1 + ] times
] final-classes
] unit-test
+
+GENERIC: infinite-loop ( a -- b )
+M: integer infinite-loop infinite-loop ;
+
+[ ] [ [ { integer } declare infinite-loop ] final-classes drop ] unit-test
+
+[ V{ tuple } ] [ [ tuple-layout <tuple> ] final-classes ] unit-test
+
+[ ] [ [ instance? ] final-classes drop ] unit-test
3bi ;
M: #recursive propagate-around ( #recursive -- )
+ "blah" USE: io print
{ 0 } clone [ USE: math
dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
constraints [ clone ] change
swap >>out-d
swap >>in-r ;
-TUPLE: #terminate < node in-d ;
+TUPLE: #terminate < node in-d in-r ;
-: #terminate ( stack -- node )
+: #terminate ( in-d in-r -- node )
\ #terminate new
+ swap >>in-r
swap >>in-d ;
TUPLE: #branch < node in-d children live-branches ;
[ unzip [ flatten-values ] bi@ zip ] change-mapping ;
M: #terminate unbox-tuples*
- [ flatten-values ] change-in-d ;
+ [ flatten-values ] change-in-d
+ [ flatten-values ] change-in-r ;
M: #phi unbox-tuples*
[ [ flatten-values ] map pad-with-bottom ] change-phi-in-d
'[ , , equate ] each ;
: equate-all ( seq disjoint-set -- )
- over dup empty? [ 2drop ] [
+ over empty? [ 2drop ] [
[ unclip-slice ] dip equate-all-with
] if ;
CREATE-METHOD
[ parse-locals-definition ] with-method-definition ;
-: parsed-lambda ( form -- )
+: parsed-lambda ( accum form -- accum )
in-lambda? get [ parsed ] [ lambda-rewrite over push-all ] if ;
PRIVATE>
M: object apply-object push-literal ;
: terminate ( -- )
- terminated? on meta-d get clone #terminate, ;
+ terminated? on meta-d get clone meta-r get clone #terminate, ;
: infer-quot ( quot rstate -- )
recursive-state get [
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces assocs kernel sequences words accessors
-definitions math effects classes arrays combinators vectors
-arrays
+definitions math math.order effects classes arrays combinators
+vectors arrays
stack-checker.state
stack-checker.visitor
stack-checker.backend
: adjust-stack-effect ( effect -- effect' )
[ in>> ] [ out>> ] bi
- meta-d get length pick length - object <repetition>
- '[ , prepend ] bi@
+ meta-d get length pick length - 0 max
+ object <repetition> '[ , prepend ] bi@
<effect> ;
: call-recursive-inline-word ( word -- )
{ 3 0 } [ [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
{ 2 0 } [ drop f f [ 2drop "A" throw ] [ ] if 2drop ] must-infer-as
+
+: unbalanced-retain-usage ( a b -- )
+ dup 10 < [ 2drop 5 1 + unbalanced-retain-usage ] [ 2drop ] if ;
+ inline recursive
+
+[ unbalanced-retain-usage ] [ inference-error? ] must-fail-with
M: f #return, drop ;
M: f #enter-recursive, 3drop ;
M: f #return-recursive, 3drop ;
-M: f #terminate, drop ;
+M: f #terminate, 2drop ;
M: f #if, 3drop ;
M: f #dispatch, 2drop ;
M: f #phi, drop drop drop drop drop ;
HOOK: #drop, stack-visitor ( values -- )
HOOK: #>r, stack-visitor ( inputs outputs -- )
HOOK: #r>, stack-visitor ( inputs outputs -- )
-HOOK: #terminate, stack-visitor ( stack -- )
+HOOK: #terminate, stack-visitor ( in-d in-r -- )
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 terminated -- )
projects / factor.git / commitdiff