Permalink
Browse files

Commondefinitionselimination.

  • Loading branch information...
1 parent e7592d6 commit 138ede661604b24274867006028bdf8fe1f9a920 Sebastiaan Visser committed Dec 20, 2009
@@ -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
View
@@ -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
View
@@ -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
+
@@ -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
@@ -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
@@ -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.
View
@@ -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 )
@@ -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)
+
@@ -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
View
@@ -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 =
View
@@ -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)

0 comments on commit 138ede6

Please sign in to comment.