Merge branch 'master' into dcn
commit
55111bdc24
|
@ -0,0 +1,140 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs deques dlists kernel locals sequences lexer
|
||||
namespaces functors compiler.cfg.rpo compiler.cfg.utilities
|
||||
compiler.cfg ;
|
||||
IN: compiler.cfg.dataflow-analysis
|
||||
|
||||
GENERIC: join-sets ( sets dfa -- set )
|
||||
GENERIC: transfer-set ( in-set bb dfa -- out-set )
|
||||
GENERIC: block-order ( cfg dfa -- bbs )
|
||||
GENERIC: successors ( bb dfa -- seq )
|
||||
GENERIC: predecessors ( bb dfa -- seq )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
MIXIN: dataflow-analysis
|
||||
|
||||
: <dfa-worklist> ( cfg dfa -- queue )
|
||||
block-order <hashed-dlist> [ push-all-front ] keep ;
|
||||
|
||||
GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
|
||||
|
||||
M: kill-block compute-in-set 3drop f ;
|
||||
|
||||
M:: basic-block compute-in-set ( bb out-sets dfa -- set )
|
||||
bb dfa predecessors [ out-sets at ] map dfa join-sets ;
|
||||
|
||||
:: update-in-set ( bb in-sets out-sets dfa -- ? )
|
||||
bb out-sets dfa compute-in-set
|
||||
bb in-sets maybe-set-at ; inline
|
||||
|
||||
GENERIC# compute-out-set 2 ( bb out-sets dfa -- set )
|
||||
|
||||
M: kill-block compute-out-set 3drop f ;
|
||||
|
||||
M:: basic-block compute-out-set ( bb in-sets dfa -- set )
|
||||
bb in-sets at bb dfa transfer-set ;
|
||||
|
||||
:: update-out-set ( bb in-sets out-sets dfa -- ? )
|
||||
bb in-sets dfa compute-out-set
|
||||
bb out-sets maybe-set-at ; inline
|
||||
|
||||
:: dfa-step ( bb in-sets out-sets dfa work-list -- )
|
||||
bb in-sets out-sets dfa update-in-set [
|
||||
bb in-sets out-sets dfa update-out-set [
|
||||
bb dfa successors work-list push-all-front
|
||||
] when
|
||||
] when ; inline
|
||||
|
||||
:: run-dataflow-analysis ( cfg dfa -- in-sets out-sets )
|
||||
H{ } clone :> in-sets
|
||||
H{ } clone :> out-sets
|
||||
cfg dfa <dfa-worklist> :> work-list
|
||||
work-list [ in-sets out-sets dfa work-list dfa-step ] slurp-deque
|
||||
in-sets
|
||||
out-sets ; inline
|
||||
|
||||
M: dataflow-analysis join-sets drop assoc-refine ;
|
||||
|
||||
FUNCTOR: define-analysis ( name -- )
|
||||
|
||||
name-analysis DEFINES-CLASS ${name}-analysis
|
||||
name-ins DEFINES ${name}-ins
|
||||
name-outs DEFINES ${name}-outs
|
||||
name-in DEFINES ${name}-in
|
||||
name-out DEFINES ${name}-out
|
||||
|
||||
WHERE
|
||||
|
||||
SINGLETON: name-analysis
|
||||
|
||||
SYMBOL: name-ins
|
||||
|
||||
: name-in ( bb -- set ) name-ins get at ;
|
||||
|
||||
SYMBOL: name-outs
|
||||
|
||||
: name-out ( bb -- set ) name-outs get at ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
! ! ! Forward dataflow analysis
|
||||
|
||||
MIXIN: forward-analysis
|
||||
INSTANCE: forward-analysis dataflow-analysis
|
||||
|
||||
M: forward-analysis block-order drop reverse-post-order ;
|
||||
M: forward-analysis successors drop successors>> ;
|
||||
M: forward-analysis predecessors drop predecessors>> ;
|
||||
|
||||
FUNCTOR: define-forward-analysis ( name -- )
|
||||
|
||||
name-analysis IS ${name}-analysis
|
||||
name-ins IS ${name}-ins
|
||||
name-outs IS ${name}-outs
|
||||
compute-name-sets DEFINES compute-${name}-sets
|
||||
|
||||
WHERE
|
||||
|
||||
INSTANCE: name-analysis forward-analysis
|
||||
|
||||
: compute-name-sets ( cfg -- )
|
||||
name-analysis run-dataflow-analysis
|
||||
[ name-ins set ] [ name-outs set ] bi* ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
! ! ! Backward dataflow analysis
|
||||
|
||||
MIXIN: backward-analysis
|
||||
INSTANCE: backward-analysis dataflow-analysis
|
||||
|
||||
M: backward-analysis block-order drop post-order ;
|
||||
M: backward-analysis successors drop predecessors>> ;
|
||||
M: backward-analysis predecessors drop successors>> ;
|
||||
|
||||
FUNCTOR: define-backward-analysis ( name -- )
|
||||
|
||||
name-analysis IS ${name}-analysis
|
||||
name-ins IS ${name}-ins
|
||||
name-outs IS ${name}-outs
|
||||
compute-name-sets DEFINES compute-${name}-sets
|
||||
|
||||
WHERE
|
||||
|
||||
INSTANCE: name-analysis backward-analysis
|
||||
|
||||
: compute-name-sets ( cfg -- )
|
||||
\ name-analysis run-dataflow-analysis
|
||||
[ name-outs set ] [ name-ins set ] bi* ;
|
||||
|
||||
;FUNCTOR
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SYNTAX: FORWARD-ANALYSIS:
|
||||
scan [ define-analysis ] [ define-forward-analysis ] bi ;
|
||||
|
||||
SYNTAX: BACKWARD-ANALYSIS:
|
||||
scan [ define-analysis ] [ define-backward-analysis ] bi ;
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays classes.mixin classes.parser
|
||||
classes.tuple classes.tuple.parser combinators effects
|
||||
effects.parser fry generic generic.parser generic.standard
|
||||
interpolate io.streams.string kernel lexer locals.parser
|
||||
locals.rewrite.closures locals.types make namespaces parser
|
||||
quotations sequences vocabs.parser words words.symbol ;
|
||||
USING: accessors arrays classes.mixin classes.parser classes.singleton
|
||||
classes.tuple classes.tuple.parser combinators effects effects.parser
|
||||
fry generic generic.parser generic.standard interpolate
|
||||
io.streams.string kernel lexer locals.parser locals.rewrite.closures
|
||||
locals.types make namespaces parser quotations sequences vocabs.parser
|
||||
words words.symbol ;
|
||||
IN: functors
|
||||
|
||||
! This is a hack
|
||||
|
@ -71,6 +71,14 @@ SYNTAX: `TUPLE:
|
|||
} case
|
||||
\ define-tuple-class parsed ;
|
||||
|
||||
SYNTAX: `SINGLETON:
|
||||
scan-param parsed
|
||||
\ define-singleton-class parsed ;
|
||||
|
||||
SYNTAX: `MIXIN:
|
||||
scan-param parsed
|
||||
\ define-mixin-class parsed ;
|
||||
|
||||
SYNTAX: `M:
|
||||
scan-param parsed
|
||||
scan-param parsed
|
||||
|
@ -134,6 +142,8 @@ DEFER: ;FUNCTOR delimiter
|
|||
: functor-words ( -- assoc )
|
||||
H{
|
||||
{ "TUPLE:" POSTPONE: `TUPLE: }
|
||||
{ "SINGLETON:" POSTPONE: `SINGLETON: }
|
||||
{ "MIXIN:" POSTPONE: `MIXIN: }
|
||||
{ "M:" POSTPONE: `M: }
|
||||
{ "C:" POSTPONE: `C: }
|
||||
{ ":" POSTPONE: `: }
|
||||
|
|
|
@ -134,3 +134,19 @@ unit-test
|
|||
[ f ] [ 1 2 H{ { 2 1 } } maybe-set-at ] unit-test
|
||||
[ t ] [ 1 3 H{ { 2 1 } } clone maybe-set-at ] unit-test
|
||||
[ t ] [ 3 2 H{ { 2 1 } } clone maybe-set-at ] unit-test
|
||||
|
||||
[ H{ { 1 2 } { 2 3 } } ] [
|
||||
{
|
||||
H{ { 1 3 } }
|
||||
H{ { 2 3 } }
|
||||
H{ { 1 2 } }
|
||||
} assoc-combine
|
||||
] unit-test
|
||||
|
||||
[ H{ { 1 7 } } ] [
|
||||
{
|
||||
H{ { 1 2 } { 2 4 } { 5 6 } }
|
||||
H{ { 1 3 } { 2 5 } }
|
||||
H{ { 1 7 } { 5 6 } }
|
||||
} assoc-refine
|
||||
] unit-test
|
|
@ -129,6 +129,9 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
: assoc-combine ( seq -- union )
|
||||
H{ } clone [ dupd update ] reduce ;
|
||||
|
||||
: assoc-refine ( seq -- assoc )
|
||||
[ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
|
||||
|
||||
: assoc-diff ( assoc1 assoc2 -- diff )
|
||||
[ nip key? not ] curry assoc-filter ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue