Debugging new optimizer

db4
Slava Pestov 2008-08-14 23:35:19 -05:00
parent a61e13f7be
commit e1987d4af9
27 changed files with 200 additions and 108 deletions

View File

@ -15,4 +15,4 @@ M: column length seq>> length ;
INSTANCE: column virtual-sequence
: <flipped> ( seq -- seq' )
dup empty? [ first length [ <column> ] with map ] unless ;
dup empty? [ dup first length [ <column> ] with map ] unless ;

View File

@ -1,6 +1,6 @@
! 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
@ -47,10 +47,10 @@ SYMBOL: +failed+
: (compile) ( word -- )
USE: prettyprint dup .
[
'[
H{ } clone dependencies set
{
, {
[ compile-begins ]
[
[ build-tree-from-word ] [ compile-failed return ] recover
@ -59,7 +59,7 @@ SYMBOL: +failed+
[ dup generate ]
[ compile-succeeded ]
} cleave
] curry with-return ;
] with-return ;
: compile-loop ( dequeue -- )
[ (compile) yield ] slurp-dequeue ;

View File

@ -92,7 +92,7 @@ M: node generate-node drop iterate-next ;
%jump-label ;
: generate-call ( label -- next )
dup maybe-compile
! dup maybe-compile
end-basic-block
dup compiling-loops get at [
%jump-label f
@ -107,7 +107,7 @@ M: node generate-node drop iterate-next ;
] ?if ;
! #recursive
: compile-recursive ( node -- )
: compile-recursive ( node -- next )
dup label>> id>> generate-call >r
[ child>> ] [ label>> word>> ] [ label>> id>> ] tri generate
r> ;
@ -115,7 +115,7 @@ M: node generate-node drop iterate-next ;
: 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 ;
@ -232,7 +232,7 @@ M: #dispatch generate-node
] 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
] [

View File

@ -1,6 +1,11 @@
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

View File

@ -22,10 +22,15 @@ IN: compiler.tree.builder
] 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 ;
@ -70,13 +75,31 @@ IN: compiler.tree.builder
[ 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 ;

View File

@ -13,14 +13,30 @@ IN: compiler.tree.cleanup
! 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?
@ -74,18 +90,6 @@ M: #call cleanup*
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>> '[
,

View File

@ -20,48 +20,47 @@ M: #phi compute-live-values*
[ [ 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
@ -70,7 +69,7 @@ M: #if remove-dead-code*
M: #phi remove-dead-code*
{
[ hoist-drops ]
! [ hoist-drops ]
[ remove-phi-inputs ]
[ remove-phi-outputs ]
[ ]

View File

@ -1,6 +1,8 @@
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
@ -10,6 +12,10 @@ 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 [
@ -32,11 +38,11 @@ IN: compiler.tree.dead-code.tests
[ 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
@ -52,9 +58,18 @@ IN: compiler.tree.dead-code.tests
[ 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
@ -76,3 +91,14 @@ IN: compiler.tree.dead-code.tests
[ [ [ 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

View File

@ -15,8 +15,14 @@ M: #enter-recursive compute-live-values*
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

View File

@ -25,11 +25,6 @@ M: #copy compute-live-values*
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 ;
@ -108,3 +103,7 @@ M: #copy remove-dead-code*
[ 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 ;

View File

@ -21,7 +21,7 @@ MACRO: match-choose ( alist -- )
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 } } [ ] }
@ -84,6 +84,12 @@ M: #r> node>quot
[ 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 )

View File

@ -43,6 +43,8 @@ M: #phi node-uses-values
[ 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 )
@ -54,6 +56,7 @@ M: #declare node-defs-values drop f ;
M: #return node-defs-values drop f ;
M: #recursive node-defs-values drop f ;
M: #terminate node-defs-values drop f ;
M: #alien-callback node-defs-values drop f ;
M: node node-defs-values out-d>> ;
: node-def-use ( node -- )

View File

@ -81,10 +81,10 @@ M: #return escape-analysis*
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 ;

View File

@ -10,7 +10,8 @@ compiler.tree.dead-code
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' )
@ -18,10 +19,12 @@ IN: compiler.tree.optimizer
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 ;

View File

@ -123,7 +123,7 @@ DEFER: (flat-length)
SYMBOL: history
: remember-inlining ( word -- )
history get [ swap suffix ] change ;
history [ swap suffix ] change ;
: inline-word ( #call word -- )
dup history get memq? [

View File

@ -253,7 +253,7 @@ generic-comparison-ops [
{ <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
@ -273,10 +273,10 @@ generic-comparison-ops [
\ 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

View File

@ -557,3 +557,12 @@ M: fixnum bad-generic 1 fixnum+fast ;
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

View File

@ -52,6 +52,7 @@ IN: compiler.tree.propagation.recursive
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

View File

@ -66,10 +66,11 @@ TUPLE: #r> < #renaming in-r out-d ;
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 ;

View File

@ -93,7 +93,8 @@ M: #shuffle unbox-tuples*
[ 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

View File

@ -92,7 +92,7 @@ M:: disjoint-set equate ( a b disjoint-set -- )
'[ , , equate ] each ;
: equate-all ( seq disjoint-set -- )
over dup empty? [ 2drop ] [
over empty? [ 2drop ] [
[ unclip-slice ] dip equate-all-with
] if ;

View File

@ -288,7 +288,7 @@ M: wlet local-rewrite*
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>

View File

@ -85,7 +85,7 @@ M: wrapper apply-object
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 [

View File

@ -1,8 +1,8 @@
! 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
@ -115,8 +115,8 @@ SYMBOL: enter-out
: 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 -- )

View File

@ -563,3 +563,9 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ;
{ 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

View File

@ -14,7 +14,7 @@ M: f #r>, 2drop ;
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 ;

View File

@ -17,7 +17,7 @@ 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 ( 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 -- )