Commondefinitionselimination.

tomlokhorst · Dec 20, 2009 · 138ede6 · 138ede6
1 parent e7592d6
commit 138ede6
Show file tree

Hide file tree

Showing 11 changed files with 165 additions and 63 deletions.
diff --git a/src/Compiler/CommonDefinitions.hs b/src/Compiler/CommonDefinitions.hs
@@ -0,0 +1,33 @@
+module Compiler.CommonDefinitions where
+
+import Compiler.Expr
+import Compiler.Generics
+import Compiler.LiftDefinitions
+import Control.Arrow hiding (app)
+import Data.Either
+import Prelude hiding (lookup)
+
+eliminate :: Arrow (~>) => Definitions ~> Definitions
+eliminate = arr (Defs . fixpoint f . unDefs)
+  where
+  f []     = []
+  f (d:ds) = d : eliminate1 d (f ds)
+
+eliminate1 :: Definition -> [Definition] -> [Definition]
+eliminate1 (Def n e) ds =
+  let (subs, keeps) = partitionEithers (map part ds)
+      part (Def m g) = if g == e && m /= n then Left m else Right (Def m g)
+  in map (\(Def m g) -> Def m (foldr (substitute1 n) g subs)) keeps
+
+substitute1 :: Var -> Var -> Expr -> Expr
+substitute1 to from = rec
+  where
+    tr (App  f e ) = app (rec f) (rec e)
+    tr (Con  c   ) = con c
+    tr (Lam  ps e) = lam ps (rec e)
+    tr (Name n e ) = name n (rec e)
+    tr (Prim s vs) = prim s (map rep vs)
+    tr (Var  u   ) = var (rep u)
+
+    rep u = if u == from then to else u
+    rec = tr . unId . out
diff --git a/src/Compiler/Expr.hs b/src/Compiler/Expr.hs
@@ -29,6 +29,15 @@ data ExprF f =
   | Var   Var
   deriving (Functor, Foldable, Traversable)
 
+instance Eq f => Eq (ExprF f) where
+  App   f g  == App   h i  = f == h && g == i
+  Con   c    == Con   d    = c == d
+  Lam   vs e == Lam   ws f = vs == ws && e == f
+  Name  n e  == Name  m f  = n == m && e == f
+  Prim  b vs == Prim  c ws = b vs == c ws
+  Var   v    == Var   w    = v == w
+  _          == _          = False
+
 type ExprA a = FixA a ExprF
 type Expr    = Fix ExprF
 

diff --git a/src/Compiler/Generics.hs b/src/Compiler/Generics.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE UndecidableInstances #-}
 module Compiler.Generics where
 
 import Data.Foldable
@@ -6,6 +7,10 @@ import Data.Monoid
 newtype FixA a f = In { out :: a f (FixA a f) }
 
 newtype Id f a = Id { unId :: f a }
+  deriving Eq
+
+instance Eq (a f (FixA a f)) => Eq (FixA a f) where
+  In x == In y = x == y
 
 type Fix f = FixA Id f
 
@@ -18,3 +23,6 @@ foldId = foldA (unId . out)
 reduce :: (Monoid a, Foldable f) => (f (Fix f) -> a) -> Fix f -> a
 reduce f = foldMap (\x -> f (unId (out x)) `mappend` reduce f x) . unId . out
 
+fixpoint :: Eq a => (a -> a) -> a -> a
+fixpoint f a = let fa = f a in if a == fa then a else fixpoint f fa
+
diff --git a/src/Compiler/InstantiateLambdas.hs b/src/Compiler/InstantiateLambdas.hs
@@ -12,22 +12,22 @@ instantiate :: Arrow (~>) => V.Val l i ~> Expr
 instantiate = arr (flip runReader 0 . tr)
   where
     tr :: V.Val l i -> Reader Integer Expr
-    tr (V.App  f a)  = app <$> tr f <*> tr a
-    tr (V.Con  c)    = pure (con c)
-    tr (V.Lam  f)    = local (+1) (ask >>= \r -> let v = 'v':show r in lam [v] <$> tr (f (V.Var v)))
-    tr (V.Name n e)  = name n <$> tr e
+    tr (V.App  f a ) = app <$> tr f <*> tr a
+    tr (V.Con  c   ) = pure (con c)
+    tr (V.Lam  f   ) = local (+1) (ask >>= \r -> let v = 'v':show r in lam [v] <$> tr (f (V.Var v)))
+    tr (V.Name n e ) = name n <$> tr e
     tr (V.Prim s vs) = pure (prim s vs)
-    tr (V.Var  v)    = pure (var v)
+    tr (V.Var  v   ) = pure (var v)
 
 dump :: Arrow (~>) => Expr ~> String
 dump = arr rec
   where
-    tr (App  f e)  = rec f ++ "(\n" ++ indent (rec e) ++ ")"
-    tr (Con  c)    = c
+    tr (App  f e ) = rec f ++ "(\n" ++ indent (rec e) ++ ")"
+    tr (Con  c   ) = c
     tr (Lam  as e) = "(function (" ++ intercalate ", " as ++ ")" ++ "\n{\n" ++ indent ("return " ++ rec e ++ ";") ++ "\n})"
-    tr (Name n e)  = "/* " ++ n ++ "*/ " ++ rec e
+    tr (Name n e ) = "/* " ++ n ++ "*/ " ++ rec e
     tr (Prim s vs) = s vs ++ " /* free: " ++ intercalate ", " vs ++ " */"
-    tr (Var  v)    = v
+    tr (Var  v   ) = v
 
     rec = tr . unId . out
     indent = unlines . map ("  "++) . lines

diff --git a/src/Compiler/LiftClosedApplications.hs b/src/Compiler/LiftClosedApplications.hs
@@ -11,25 +11,27 @@ import Data.Traversable
 import qualified Data.Set as S
 
 lift :: Arrow (~>) => DefinitionsFV ~> Definitions
-lift = arr (Defs . concatMap single . unDefs)
+lift = arr (Defs . concat . zipWith single [0..] . unDefs)
 
   where
-  single (Def n e) = let (g, (_, ds)) = runState (coll e) (0, []) in ds ++ [Def n g]
+  single i (Def n x) = let (g, (_, ds)) = runState (coll True x) (i, []) in ds ++ [Def n g]
 
-  coll (In (FreeVarA vf e)) =
-    if S.size vf == 0 && liftable e
-      then var . mk <$> (rec e >>= store)
-      else rec e
+    where
+    coll top (In (FreeVarA vf e)) =
+      if not top && S.size vf == 0 && liftable e
+        then var . mk <$> (rec e >>= store)
+        else rec e
 
-  rec = fmap (In . Id) . traverse coll
+    rec = fmap (In . Id) . traverse (coll False)
 
-  liftable (App _ _) = True
-  liftable _         = False
+    liftable (App _ _) = True
+    liftable (Lam _ _) = True
+    liftable _         = False
 
-  mk = ('c':) . show
+    mk v = 'c': (show i ++ "_" ++ show v)
 
-  store :: Expr -> State (Integer, [Definition]) Integer
-  store e =
-    do modify $ \(i, defs) -> (i + 1, defs ++ [Def (mk (i + 1)) e])
-       gets fst
+    store :: Expr -> State (Integer, [Definition]) Integer
+    store e =
+      do modify $ \(j, defs) -> (j + 1, defs ++ [Def (mk (j + 1)) e])
+         gets fst
 
diff --git a/src/Compiler/LiftDefinitions.hs b/src/Compiler/LiftDefinitions.hs
@@ -21,9 +21,12 @@ data DefinitionA a = Def
 
 newtype DefinitionsA a = Defs { unDefs :: [DefinitionA a] }
 
-type Definition  = DefinitionA Id
+type Definition  = DefinitionA  Id
 type Definitions = DefinitionsA Id
 
+deriving instance Eq (DefinitionA  Id)
+deriving instance Eq (DefinitionsA Id)
+
 -- All named sub-expressions will be replaces by a variables that references
 -- the definition that will be created. All named sub-expression MUST NOT
 -- contain any free variables.
@@ -41,8 +44,8 @@ inline = foldId (In . Id . fmap defs)
 collect :: Expr -> [Definition]
 collect = reduce defs
   where
-  defs d@(Name n _) = [Def n (In (Id d))]
-  defs _            = []
+  defs (Name n d) = [Def n d]
+  defs _          = []
 
 -- Lift all definitions to the top-level and inline all references to these
 -- definitions in the main expression.

diff --git a/src/Compiler/Pipeline.hs b/src/Compiler/Pipeline.hs
@@ -10,6 +10,8 @@ import qualified Compiler.InstantiateLambdas     as Lambdas
 import qualified Compiler.FreeVariables          as FreeVariables
 import qualified Compiler.LiftClosedApplications as ClosedApplications
 import qualified Compiler.LiftDefinitions        as Definitions
+import qualified Compiler.ReindexParamaters      as Parameters
+import qualified Compiler.CommonDefinitions      as CommonDefinitions
 
 type a :-> b = Kleisli IO a b
 
@@ -20,5 +22,7 @@ compiler = runKleisli
   >>> ( Definitions.eliminiateDoubles     :: Definitions   :-> Definitions   )
   >>> ( FreeVariables.annotateDefinitions :: Definitions   :-> DefinitionsFV )
   >>> ( ClosedApplications.lift           :: DefinitionsFV :-> Definitions   )
+  >>> ( Parameters.reindex                :: Definitions   :-> Definitions   )
+  >>> ( CommonDefinitions.eliminate       :: Definitions   :-> Definitions   )
   >>> ( Definitions.dump                  :: Definitions   :-> String        )
 
diff --git a/src/Compiler/ReindexParamaters.hs b/src/Compiler/ReindexParamaters.hs
@@ -0,0 +1,32 @@
+module Compiler.ReindexParamaters where
+
+import Compiler.Expr
+import Compiler.Generics
+import Compiler.LiftDefinitions
+import Control.Applicative hiding (empty)
+import Control.Arrow hiding (app)
+import Control.Monad.State
+import Data.Map (Map, insert, lookup, empty)
+import Data.Maybe
+import Prelude hiding (lookup)
+
+reindex :: Arrow (~>) => Definitions ~> Definitions
+reindex = arr (Defs . map one . unDefs)
+  where
+
+  one (Def nm x) = let e = fst $ runState (rec x) (0, empty) in Def nm e
+    where
+
+    tr :: ExprF Expr -> State (Integer, Map Var Integer) Expr
+    tr (App  f e ) = app <$> rec f <*> rec e
+    tr (Con  c   ) = return (con c)
+    tr (Lam  ps e) = do qs <- mapM (\p -> modify (\(c, m) -> (c + 1, insert p (c + 1) m)) >> gets (mk . fst)) ps
+                        lam qs <$> rec e
+    tr (Name n e ) = name n <$> rec e
+    tr (Prim s vs) = prim s <$> mapM subst vs
+    tr (Var  v   ) = subst v >>= return . var
+
+    rec = tr . unId . out
+    mk = ('v':) . show
+    subst v = gets (maybe v mk . lookup v . snd)
+
diff --git a/src/Generic/Data/Number.hs b/src/Generic/Data/Number.hs
@@ -3,6 +3,11 @@ module Generic.Data.Number where
 import Prelude ()
 import qualified Prelude
 
+infixl 6 +
+infixl 7 *
+infixl 7 /
+infixl 6 -
+
 data Num
 class NumC j where
   (+) :: j Num -> j Num -> j Num

diff --git a/src/Main.hs b/src/Main.hs
@@ -5,8 +5,8 @@ import Generic.Prelude
 import Lang.JavaScript
 import qualified Prelude as P
 
-jsSumList :: Js Num
-jsSumList = sum (replicate 3 8 ++ replicate 3 8) * maybe 4 (*8) (just (3 - 2))
+jsSumList :: JavaScript Num
+jsSumList = sum (replicate 3 (2 * 8) ++ replicate 3 8) * maybe 4 (*8) (just (3 - 2))
 
 main :: P.IO ()
 main =

diff --git a/src/test.js b/src/test.js
@@ -1,35 +1,41 @@
-var mul = /* mul */ function (v1) { return function (v2) { return v1 * v2; }; }
-var fix = /* fix */ function (v1) { return fix = arguments.callee, v1(function (i) { return fix(v1)(i) }); }
-var list = /* list */ function (v3) { return function (v4) { return function (v5) { return v5.nil ? v3 : v4(v5.head)(v5.tail); }; }; }
-var add = /* add */ function (v5) { return function (v6) { return v5 + v6; }; }
-var bool = /* bool */ function (v5) { return function (v6) { return function (v7) { return v7 ? v5(/*force*/) : v6(/*force*/); }; }; }
-var cons = /* cons */ function (v6) { return function (v7) { return { head : v6, tail : v7 }; }; }
-var sub = /* sub */ function (v6) { return function (v7) { return v6 - v7; }; }
-var eq = /* eq */ function (v5) { return function (v6) { return v5 == v6; }; }
-var maybe = /* maybe */ function (v1) { return function (v2) { return function (v3) { return v3.nothing ? v1 : v2(v3.just); }; }; }
-var just = /* just */ function (v1) { return { just : v1 }; }
-var c1 = list(0)
-var c2 = fix(function (v1) { return function (v2) { return c1(function (v3) { return function (v4) { return add(v3)(v1(v4)); }; })(v2); }; })
-var c3 = function (v6) { return function (v7) { return v6; }; }({ nil : 1 })
-var c4 = bool(function (v5) { return c3(v5); })
-var c5 = cons(8)
-var c6 = fix(function (v3) { return function (v4) { return c4(function (v5) { return function (v6) { return function (v7) { return v6; }; }(c5(v3(sub(v4)(1))))(v5); })(eq(v4)(0)); }; })
-var c7 = c6(3)
-var c8 = list(c7)
-var c9 = fix(function (v1) { return function (v2) { return c8(function (v3) { return function (v4) { return cons(v3)(v1(v4)); }; })(v2); }; })
-var c10 = function (v4) { return function (v5) { return v4; }; }({ nil : 1 })
-var c11 = bool(function (v3) { return c10(v3); })
-var c12 = cons(8)
-var c13 = fix(function (v1) { return function (v2) { return c11(function (v3) { return function (v4) { return function (v5) { return v4; }; }(c12(v1(sub(v2)(1))))(v3); })(eq(v2)(0)); }; })
-var c14 = c13(3)
-var c15 = c9(c14)
-var c16 = c2(c15)
-var c17 = mul(c16)
-var c18 = maybe(4)
-var c19 = c18(function (v1) { return mul(v1)(8); })
-var c20 = sub(3)
-var c21 = c20(2)
-var c22 = just(c21)
-var c23 = c19(c22)
-var c24 = c17(c23)
-var __main = c24
+var mul = function (v1) { return function (v2) { return v1 * v2; }; }
+var fix = function (v1) { return fix = arguments.callee, v1(function (i) { return fix(v1)(i) }); }
+var list = function (v1) { return function (v2) { return function (v3) { return v3.nil ? v1 : v2(v3.head)(v3.tail); }; }; }
+var add = function (v1) { return function (v2) { return v1 + v2; }; }
+var bool = function (v1) { return function (v2) { return function (v3) { return v3 ? v1(/*force*/) : v2(/*force*/); }; }; }
+var cons = function (v1) { return function (v2) { return { head : v1, tail : v2 }; }; }
+var sub = function (v1) { return function (v2) { return v1 - v2; }; }
+var eq = function (v1) { return function (v2) { return v1 == v2; }; }
+var maybe = function (v1) { return function (v2) { return function (v3) { return v3.nothing ? v1 : v2(v3.just); }; }; }
+var just = function (v1) { return { just : v1 }; }
+var c10_11 = list(0)
+var c10_12 = function (v1) { return function (v2) { return c10_11(function (v3) { return function (v4) { return add(v3)(v1(v4)); }; })(v2); }; }
+var c10_13 = fix(c10_12)
+var c10_14 = function (v1) { return function (v2) { return v1; }; }
+var c10_15 = c10_14({ nil : 1 })
+var c10_16 = function (v1) { return c10_15(v1); }
+var c10_17 = bool(c10_16)
+var c10_19 = cons(8)
+var c10_20 = function (v1) { return function (v2) { return c10_17(function (v3) { return c10_14(c10_19(v1(sub(v2)(1))))(v3); })(eq(v2)(0)); }; }
+var c10_21 = fix(c10_20)
+var c10_22 = c10_21(3)
+var c10_23 = list(c10_22)
+var c10_24 = function (v1) { return function (v2) { return c10_23(function (v3) { return function (v4) { return cons(v3)(v1(v4)); }; })(v2); }; }
+var c10_25 = fix(c10_24)
+var c10_31 = mul(2)
+var c10_32 = c10_31(8)
+var c10_33 = cons(c10_32)
+var c10_34 = function (v1) { return function (v2) { return c10_17(function (v3) { return c10_14(c10_33(v1(sub(v2)(1))))(v3); })(eq(v2)(0)); }; }
+var c10_35 = fix(c10_34)
+var c10_36 = c10_35(3)
+var c10_37 = c10_25(c10_36)
+var c10_38 = c10_13(c10_37)
+var c10_39 = mul(c10_38)
+var c10_40 = maybe(4)
+var c10_41 = function (v1) { return mul(v1)(8); }
+var c10_42 = c10_40(c10_41)
+var c10_43 = sub(3)
+var c10_44 = c10_43(2)
+var c10_45 = just(c10_44)
+var c10_46 = c10_42(c10_45)
+var __main = c10_39(c10_46)