Various fixes

db4
Slava Pestov 2008-08-09 23:00:27 -05:00
parent 0097b1d89d
commit ca57e4386c
17 changed files with 173 additions and 64 deletions

View File

@ -0,0 +1,61 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel sets namespaces accessors assocs
arrays combinators continuations
compiler.tree
compiler.tree.def-use
compiler.tree.combinators ;
IN: compiler.tree.checker
! Check some invariants.
ERROR: check-use-error value message ;
: check-use ( value uses -- )
[ empty? [ "No use" check-use-error ] [ drop ] if ]
[ all-unique? [ drop ] [ "Uses not all unique" check-use-error ] if ] 2bi ;
: check-def-use ( -- )
def-use get [ uses>> check-use ] assoc-each ;
GENERIC: check-node ( node -- )
M: #shuffle check-node
[ [ mapping>> values ] [ in-d>> ] bi subset? [ "Bad mapping inputs" throw ] unless ]
[ [ mapping>> keys ] [ out-d>> ] bi set= [ "Bad mapping outputs" throw ] unless ]
bi ;
: check-lengths ( seq -- )
[ length ] map all-equal? [ "Bad lengths" throw ] unless ;
M: #copy check-node inputs/outputs 2array check-lengths ;
M: #>r check-node inputs/outputs 2array check-lengths ;
M: #r> check-node inputs/outputs 2array check-lengths ;
M: #return-recursive check-node inputs/outputs 2array check-lengths ;
M: #phi check-node
{
[ [ phi-in-d>> ] [ out-d>> ] bi 2array check-lengths ]
[ [ phi-in-r>> ] [ out-r>> ] bi 2array check-lengths ]
[ phi-in-d>> check-lengths ]
[ phi-in-r>> check-lengths ]
} cleave ;
M: #enter-recursive check-node
[ [ in-d>> ] [ out-d>> ] bi 2array check-lengths ]
[ [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix check-lengths ]
bi ;
M: #push check-node
out-d>> length 1 = [ "Bad #push" throw ] unless ;
M: node check-node drop ;
ERROR: check-node-error node error ;
: check-nodes ( nodes -- )
compute-def-use
check-def-use
[ [ check-node ] [ check-node-error ] recover ] each-node ;

View File

@ -105,10 +105,10 @@ SYMBOL: live-branches
M: #branch cleanup*
{
[ live-branches>> live-branches set ]
[ delete-unreachable-branches ]
[ cleanup-children ]
[ fold-only-branch ]
[ live-branches>> live-branches set ]
} cleave ;
: cleanup-phi-in ( phi-in live-branches -- phi-in' )
@ -122,7 +122,8 @@ M: #phi cleanup*
[ '[ , cleanup-phi-in ] change-phi-in-r ]
[ '[ , cleanup-phi-in ] change-phi-info-d ]
[ '[ , cleanup-phi-in ] change-phi-info-r ]
} cleave ;
} cleave
live-branches off ;
: >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi #copy ;

View File

@ -1,8 +1,9 @@
! 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 ;
kernel sequences words sets
stack-checker.branches stack-checker.inlining
compiler.tree compiler.tree.def-use compiler.tree.combinators ;
IN: compiler.tree.dataflow-analysis
! Dataflow analysis
@ -34,5 +35,5 @@ SYMBOL: work-list
: dfa ( node mark-quot iterate-quot -- assoc )
init-dfa
[ each-node ] dip
work-list get H{ { f f } } clone
work-list get H{ { +bottom+ f } } clone
[ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline

View File

@ -1,7 +1,9 @@
USING: accessors namespaces assocs kernel sequences math
tools.test words sets combinators.short-circuit
stack-checker.state compiler.tree compiler.tree.builder
compiler.tree.def-use arrays kernel.private ;
compiler.tree.normalization compiler.tree.propagation
compiler.tree.cleanup compiler.tree.def-use arrays kernel.private
sorting math.order binary-search compiler.tree.checker ;
IN: compiler.tree.def-use.tests
\ compute-def-use must-infer
@ -14,8 +16,16 @@ IN: compiler.tree.def-use.tests
} 1&&
] unit-test
! compute-def-use checks for SSA violations, so we make sure
! some common patterns are generated correctly.
: test-def-use ( quot -- )
build-tree
normalize
propagate
cleanup
compute-def-use
check-nodes ;
! compute-def-use checks for SSA violations, so we use that to
! ensure we generate some common patterns correctly.
{
[ [ drop ] each-integer ]
[ [ 2drop ] curry each-integer ]
@ -28,6 +38,10 @@ IN: compiler.tree.def-use.tests
[ [ 1 ] 2 [ + ] curry compose call + ]
[ [ 1 ] [ call 2 ] curry call + ]
[ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ]
[ dup slice? [ dup array? [ ] [ ] if ] [ ] if ]
[ dup [ drop f ] [ "A" throw ] if ]
[ [ <=> ] sort ]
[ [ <=> ] with search ]
} [
[ ] swap [ build-tree compute-def-use drop ] curry unit-test
[ ] swap [ test-def-use ] curry unit-test
] each

View File

@ -1,8 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays namespaces assocs sequences kernel generic assocs
classes vectors accessors combinators sets stack-checker.state
compiler.tree compiler.tree.combinators ;
classes vectors accessors combinators sets
stack-checker.state
stack-checker.branches
compiler.tree
compiler.tree.combinators ;
IN: compiler.tree.def-use
SYMBOL: def-use
@ -37,7 +40,8 @@ M: #introduce node-uses-values drop f ;
M: #push node-uses-values drop f ;
M: #r> node-uses-values in-r>> ;
M: #phi node-uses-values
[ phi-in-d>> ] [ phi-in-r>> ] bi append concat sift prune ;
[ phi-in-d>> ] [ phi-in-r>> ] bi
append concat remove-bottom prune ;
M: #declare node-uses-values declaration>> keys ;
M: node node-uses-values in-d>> ;
@ -57,14 +61,6 @@ M: node node-defs-values out-d>> ;
[ dup node-uses-values [ use-value ] with each ]
[ dup node-defs-values [ def-value ] with each ] bi ;
: check-use ( uses -- )
[ empty? [ "No use" throw ] when ]
[ all-unique? [ "Uses not all unique" throw ] unless ] bi ;
: check-def-use ( -- )
def-use get [ nip uses>> check-use ] assoc-each ;
: compute-def-use ( node -- node )
H{ } clone def-use set
dup [ node-def-use ] each-node
check-def-use ;
dup [ node-def-use ] each-node ;

View File

@ -9,7 +9,9 @@ compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.branches
M: #branch escape-analysis*
live-children sift [ (escape-analysis) ] each ;
[ in-d>> add-escaping-values ]
[ live-children sift [ (escape-analysis) ] each ]
bi ;
: (merge-allocations) ( values -- allocation )
[
@ -25,7 +27,7 @@ M: #branch escape-analysis*
] map ;
: merge-allocations ( in-values out-values -- )
[ [ sift ] map ] dip
[ [ remove-bottom ] map ] dip
[ [ merge-values ] 2each ]
[ [ (merge-allocations) ] dip record-allocations ]
2bi ;

View File

@ -5,7 +5,8 @@ compiler.tree.normalization math.functions
compiler.tree.propagation compiler.tree.cleanup
compiler.tree.combinators compiler.tree sequences math math.private
kernel tools.test accessors slots.private quotations.private
prettyprint classes.tuple.private classes classes.tuple ;
prettyprint classes.tuple.private classes classes.tuple
compiler.tree.intrinsics ;
\ escape-analysis must-infer
@ -15,7 +16,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
out-d>> first escaping-allocation? [ 1+ ] unless ;
M: #call count-unboxed-allocations*
dup word>> { <tuple-boa> <complex> } memq?
dup word>> { <immutable-tuple-boa> <complex> } memq?
[ (count-unboxed-allocations) ] [ drop ] if ;
M: #push count-unboxed-allocations*

View File

@ -18,9 +18,7 @@ IN: compiler.tree.escape-analysis.recursive
} cond ;
: check-fixed-point ( node alloc1 alloc2 -- )
[ congruent? ] 2all? [ drop ] [
label>> f >>fixed-point drop
] if ;
[ congruent? ] 2all? [ drop ] [ label>> f >>fixed-point drop ] if ;
: node-input-allocations ( node -- allocations )
in-d>> [ allocation ] map ;
@ -44,13 +42,14 @@ IN: compiler.tree.escape-analysis.recursive
] 2bi ;
M: #recursive escape-analysis* ( #recursive -- )
[
{ 0 } clone [ USE: math
dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
child>>
[ first out-d>> introduce-values ]
[ first analyze-recursive-phi ]
[ (escape-analysis) ]
tri
] until-fixed-point ;
] curry until-fixed-point ;
M: #enter-recursive escape-analysis* ( #enter-recursive -- )
#! Handled by #recursive

View File

@ -33,8 +33,10 @@ DEFER: record-literal-allocation
} cond ;
: record-literal-allocation ( value object -- )
object-slots dup
[ make-literal-slots swap record-allocation ] [ 2drop ] if ;
object-slots
[ make-literal-slots swap record-allocation ]
[ unknown-allocation ]
if* ;
M: #push escape-analysis*
#! Delegation.

View File

@ -1,6 +1,6 @@
IN: compiler.tree.normalization.tests
USING: compiler.tree.builder compiler.tree.normalization
compiler.tree sequences accessors tools.test kernel ;
compiler.tree sequences accessors tools.test kernel math ;
\ count-introductions must-infer
\ fixup-enter-recursive must-infer
@ -25,3 +25,5 @@ compiler.tree sequences accessors tools.test kernel ;
[ recursive-inputs ]
[ normalize recursive-inputs ] bi
] unit-test
[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize drop ] unit-test

View File

@ -1,7 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry namespaces sequences math accessors kernel arrays
stack-checker.backend stack-checker.inlining compiler.tree
stack-checker.backend
stack-checker.branches
stack-checker.inlining
compiler.tree
compiler.tree.combinators ;
IN: compiler.tree.normalization
@ -97,7 +100,12 @@ M: #branch eliminate-introductions*
bi ;
: eliminate-phi-introductions ( introductions seq terminated -- seq' )
[ flip ] dip [ [ nip ] [ over length tail append ] if ] 3map flip ;
[ flip ] dip [
[ nip ] [
dup [ +bottom+ eq? ] left-trim
[ [ length ] bi@ - tail* ] keep append
] if
] 3map flip ;
M: #phi eliminate-introductions*
remaining-introductions get swap dup terminated>>

View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: fry kernel sequences assocs accessors namespaces
math.intervals arrays classes.algebra combinators
stack-checker.branches
compiler.tree
compiler.tree.def-use
compiler.tree.combinators
@ -59,7 +60,14 @@ SYMBOL: infer-children-data
: compute-phi-input-infos ( phi-in -- phi-info )
infer-children-data get
'[ , [ [ [ value-info ] [ null-info ] if* ] bind ] 2map ] map ;
'[
, [
[
dup +bottom+ eq?
[ drop null-info ] [ value-info ] if
] bind
] 2map
] map ;
: annotate-phi-inputs ( #phi -- )
dup phi-in-d>> compute-phi-input-infos >>phi-info-d
@ -139,10 +147,10 @@ M: #phi propagate-before ( #phi -- )
M: #phi propagate-after ( #phi -- )
condition-value get [
[ out-d>> ] [ phi-in-d>> ] [ phi-info-d>> ] tri
3array flip [
first3 [ possible-boolean-values ] map
[
[ possible-boolean-values ] map
branch-phi-constraints
] each
] 3each
] [ drop ] if ;
M: #phi propagate-around ( #phi -- )

View File

@ -2,6 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences assocs math kernel accessors fry
combinators sets locals
stack-checker.branches
compiler.tree
compiler.tree.def-use
compiler.tree.combinators ;
@ -42,7 +43,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
#! An output is a copy of every input if all inputs are
#! copies of the same original value.
[
swap sift [ resolve-copy ] map
swap remove-bottom [ resolve-copy ] map
dup [ all-equal? ] [ empty? not ] bi and
[ first swap is-copy-of ] [ 2drop ] if
] 2each ;

View File

@ -39,7 +39,7 @@ IN: compiler.tree.propagation.recursive
: unify-recursive-stacks ( stacks initial -- infos )
over empty? [ nip ] [
[
[ sift value-infos-union ] dip
[ value-infos-union ] dip
[ generalize-counter ] keep
value-info-union
] 2map

View File

@ -1,24 +1,22 @@
IN: compiler.tree.tuple-unboxing.tests
USING: tools.test compiler.tree.tuple-unboxing
compiler.tree compiler.tree.builder compiler.tree.normalization
USING: tools.test compiler.tree.tuple-unboxing compiler.tree
compiler.tree.builder compiler.tree.normalization
compiler.tree.propagation compiler.tree.cleanup
compiler.tree.escape-analysis compiler.tree.tuple-unboxing
compiler.tree.def-use kernel accessors sequences math
sorting math.order binary-search ;
compiler.tree.checker compiler.tree.def-use kernel accessors
sequences math math.private sorting math.order binary-search
sequences.private slots.private ;
\ unbox-tuples must-infer
: test-unboxing ( quot -- )
#! Just make sure it doesn't throw errors; compute def use
#! for kicks.
build-tree
normalize
propagate
cleanup
escape-analysis
unbox-tuples
compute-def-use
drop ;
check-nodes ;
TUPLE: cons { car read-only } { cdr read-only } ;
@ -30,6 +28,12 @@ TUPLE: empty-tuple ;
[ cons boa [ car>> ] [ cdr>> ] bi ]
[ [ 1 cons boa ] [ 2 cons boa ] if car>> ]
[ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
[ 2 cons boa { [ ] [ ] } dispatch ]
[ dup [ drop f ] [ "A" throw ] if ]
[ [ ] [ ] curry curry dup 3 slot swap 4 slot dup 3 slot swap 4 slot drop ]
[ [ ] [ ] curry curry call ]
[ <complex> <complex> dup 1 slot drop 2 slot drop ]
[ 1 cons boa over [ "A" throw ] when car>> ]
[ [ <=> ] sort ]
[ [ <=> ] with search ]
} [ [ ] swap [ test-unboxing ] curry unit-test ] each

View File

@ -3,6 +3,7 @@
USING: namespaces assocs accessors kernel combinators
classes.algebra sequences sequences.deep slots.private
classes.tuple.private math math.private arrays
stack-checker.branches
compiler.tree
compiler.tree.intrinsics
compiler.tree.combinators
@ -43,15 +44,13 @@ M: #push unbox-tuples* ( #push -- nodes )
: flatten-values ( values -- values' )
(flatten-values) flatten ;
: flatten-value ( values -- values )
[ unboxed-allocation ] [ 1array ] bi or ;
: prepare-slot-access ( #call -- tuple-values outputs slot-values )
[ in-d>> first flatten-value ]
[ in-d>> flatten-values ]
[ out-d>> flatten-values ]
[
out-d>> first slot-accesses get at
[ slot#>> ] [ value>> ] bi allocation nth flatten-value
[ slot#>> ] [ value>> ] bi allocation nth
1array flatten-values
] tri ;
: slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
@ -73,7 +72,8 @@ M: #call unbox-tuples*
} case ;
M: #declare unbox-tuples*
[ unzip [ flatten-values ] dip zip ] change-declaration ;
#! We don't look at declarations after propagation anyway.
f >>declaration ;
M: #copy unbox-tuples*
[ flatten-values ] change-in-d
@ -96,9 +96,9 @@ M: #terminate unbox-tuples*
[ flatten-values ] change-in-d ;
M: #phi unbox-tuples*
[ flip [ flatten-values ] map flip ] change-phi-in-d
[ flip [ flatten-values ] map flip ] change-phi-in-r
[ flatten-values ] change-out-d
[ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-d
[ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-r
[ flatten-values ] change-out-d
[ flatten-values ] change-out-r ;
M: #recursive unbox-tuples*

View File

@ -9,21 +9,30 @@ IN: stack-checker.branches
: balanced? ( pairs -- ? )
[ second ] filter [ first2 length - ] map all-equal? ;
: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
dup [ [ - f <repetition> ] dip append ] [ 3drop f ] if ;
SYMBOL: +bottom+
: pad-with-f ( seq -- newseq )
dup [ length ] map supremum '[ , f pad-left ] map ;
: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
dup [ [ - +bottom+ <repetition> ] dip append ] [ 3drop f ] if ;
: pad-with-bottom ( seq -- newseq )
dup empty? [
dup [ length ] map supremum
'[ , +bottom+ pad-left ] map
] unless ;
: phi-inputs ( max-d-in pairs -- newseq )
dup empty? [ nip ] [
swap '[ , _ first2 unify-inputs ] map
pad-with-f
pad-with-bottom
flip
] if ;
: remove-bottom ( seq -- seq' )
+bottom+ swap remove ;
: unify-values ( values -- phi-out )
sift dup empty? [ drop <value> ] [
remove-bottom
dup empty? [ drop <value> ] [
[ known ] map dup all-eq?
[ first make-known ] [ drop <value> ] if
] if ;