Merge branch 'master' into dcn

basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor

@@ -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 ;

basis/functors/functors.factor

@@ -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: `: }

core/assocs/assocs-tests.factor

@@ -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

core/assocs/assocs.factor

@@ -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 ;