Permalink
Browse files

Refactors. lots.

  • Loading branch information...
1 parent a07bd06 commit d28bdc0acdee6ebf86a20d85b66c00818465ec46 Sebastiaan Visser committed Dec 19, 2009
@@ -1,22 +0,0 @@
-module Compiler.Compiler where
-
-import Compiler.CodeGen
-import Compiler.Instantiate
-import Compiler.LambdaLifting
-import Compiler.Renamer
-import Compiler.CSE
-import Control.Arrow
-import Control.Category
-import Lang.JavaScript
-import Prelude hiding ((.), id)
-
-compiler :: Js a -> IO String
-compiler =
- runKleisli
- $ concatDefinitions
- . generateCodeDefinitions
- . renameNamedDefinitions
- . commonSubExpressionElimination
- . liftLambdas
- . instantiateLambas
-
@@ -0,0 +1,20 @@
+module Compiler.Generics where
+
+import Data.Foldable
+import Data.Monoid
+
+newtype FixA a f = In { out :: a f (FixA a f) }
+
+newtype Id f a = Id { unId :: f a }
+
+type Fix f = FixA Id f
+
+foldA :: Functor f => (FixA a f -> f (FixA a f)) -> (f c -> c) -> FixA a f -> c
+foldA un f = f . fmap (foldA un f) . un
+
+foldId :: Functor f => (f c -> c) -> FixA Id f -> c
+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
+
@@ -1,7 +0,0 @@
-
--- inliner (vm, x) =
--- let uses = map snd . filter ((<=1) . fst) . map (length &&& head) . group . sort . concatMap toList . Map.elems $ vm :: [String]
--- rep from to x = if x == from then to else x
--- once (f, t) = Map.map (fmap (rep f t))
--- in undefined -- (foldr once vm uses, x)
-
@@ -1,18 +1,34 @@
-module Compiler.Instantiate (instantiateLambas) where
+module Compiler.Instantiate (instantiateLambas, anonymousExprPrinter) where
+import Compiler.Generics
import Compiler.Raw
-import Control.Arrow hiding (app)
import Control.Applicative
+import Control.Arrow hiding (app)
import Control.Monad.Reader
+import Data.List (intercalate)
import qualified Lang.Value as V
-instantiateLambas :: Show (V.Primitive l) => Kleisli IO (V.Val l i) Expr
+instantiateLambas :: Arrow (~>) => V.Val l i ~> Expr
instantiateLambas = 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.Prim s vs) = pure (prim s vs)
+ tr (V.Lam f) = local (+1) (ask >>= \r -> let v = 'v':show r in lam [v] <$> tr (f (V.Var v)))
+ tr (V.Var v) = pure (var v)
+ tr (V.Name n e) = def n <$> tr e
+
+anonymousExprPrinter :: Arrow (~>) => Expr ~> String
+anonymousExprPrinter = arr tr
+ where
+ tr (In (Id (App f e))) = tr f ++ "(\n" ++ indent (tr e) ++ ")"
+ tr (In (Id (Con c))) = c
+ tr (In (Id (Prim s vs))) = s ++ " /* free: " ++ intercalate ", " vs ++ " */"
+ tr (In (Id (Lam as e))) = "(function (" ++ intercalate ", " as ++ ")" ++ "\n{\n" ++ indent ("return " ++ tr e ++ ";") ++ "\n})"
+ tr (In (Id (Var v))) = v
+ tr (In (Id (Def n e))) = "/* " ++ n ++ "*/ " ++ tr e
+ tr (In (Id (More es))) = intercalate "\n" (map tr es)
-tr :: Show (V.Primitive l) => V.Val l i -> Reader Integer Expr
-tr (V.App f a) = app <$> tr f <*> tr a
-tr (V.Prim s) = pure (prim (show s))
-tr (V.Lam f) = local (+1) (ask >>= \r -> lam ['v':show r] <$> tr (f (V.Var r)))
-tr (V.Var x) = pure (var ('v':show x))
-tr (V.Name x v) = name x <$> tr v
+ indent = unlines . map (" "++) . lines
@@ -0,0 +1,52 @@
+module Compiler.LiftDefinitions
+ ( inlineDefinitions
+ , collectDefinitions
+ , liftDefinitions
+ , definitionsPrinter
+ ) where
+
+import Compiler.Generics
+import Compiler.Raw
+import Data.Map (Map, singleton, empty, elems)
+import Control.Arrow hiding (app)
+import Data.List (intercalate)
+
+-- All named definitions within expression will be replaces by a variables with
+-- the name of the definitions.
+
+inlineDefinitions :: Expr -> Expr
+inlineDefinitions = foldId (In . Id . fmap defs)
+ where
+ defs (In (Id (Def n _))) = var n
+ defs e = e
+
+-- Collect all definitions from an expression tree and return a map with
+-- name/definition pairs. Because of the Map datatype all duplicate definitions
+-- will be joined to a single one.
+
+collectDefinitions :: Expr -> Map String Expr
+collectDefinitions = reduce defs
+ where
+ defs d@(Def n _) = singleton n (In (Id d))
+ defs _ = empty
+
+-- Lift all definitions to the top-level and inline all references to these
+-- definitions.
+
+liftDefinitions :: Arrow (~>) => Expr ~> Expr
+liftDefinitions = arr (\e -> more (elems (collectDefinitions e) ++ [tr e]))
+ where
+ tr d@(In (Id (Def _ _))) = d
+ tr e = inlineDefinitions e
+
+definitionsPrinter :: Arrow (~>) => Expr ~> String
+definitionsPrinter = arr tr
+ where
+ tr (In (Id (App f e))) = tr f ++ "(" ++ tr e ++ ")"
+ tr (In (Id (Con c))) = c
+ tr (In (Id (Prim s _))) = s
+ tr (In (Id (Lam as e))) = "(function (" ++ intercalate ", " as ++ ")" ++ "{ " ++ "return " ++ tr e ++ ";" ++ " })"
+ tr (In (Id (Var v))) = v
+ tr (In (Id (Def n e))) = n ++ " = " ++ tr e
+ tr (In (Id (More es))) = intercalate "\n" (map tr es)
+
@@ -0,0 +1,15 @@
+{-# LANGUAGE Arrows #-}
+module Compiler.Pipeline where
+
+import Compiler.Instantiate
+import Compiler.LiftDefinitions
+import Control.Arrow
+import Lang.Value
+
+compiler :: Val l i -> IO String
+compiler = runKleisli $ proc i ->
+ do r <- instantiateLambas -< i
+ l <- liftDefinitions -< r
+ p <- definitionsPrinter -< l
+ returnA -< p
+
View
@@ -1,17 +1,17 @@
{-# LANGUAGE
TypeFamilies
, FlexibleContexts
- , UndecidableInstances
, DeriveFunctor
, DeriveFoldable
, DeriveTraversable
#-}
module Compiler.Raw where
+import Compiler.Generics
import Control.Applicative
import Control.Monad.State
import Data.Foldable hiding (elem, mapM_, concatMap, concat, foldr)
-import Data.Map
+import Data.Map (Map, lookup)
import Data.Maybe
import Data.Monoid
import Data.Traversable hiding (mapM)
@@ -21,47 +21,46 @@ import qualified Data.Set as Set
-- Raw value datatype.
-type Name = String
-
data ExprF f =
App f f
- | Prim String
- | Lam [Name] f
- | Var Name
- | Name Name f
+ | Con String
+ | Prim String [String]
+ | Lam [String] f
+ | Var String
+ | Def String f
| More [f]
- deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
-
-newtype Fix f = In { out :: f (Fix f) }
+ deriving (Eq, Ord, Functor, Foldable, Traversable)
type Expr = Fix ExprF
-- Smart constructors.
app :: Expr -> Expr -> Expr
-app a b = In (App a b )
+app a b = In (Id (App a b))
+
+con :: String -> Expr
+con a = In (Id (Con a))
-prim :: String -> Expr
-prim a = In (Prim a )
+prim :: String -> [String] -> Expr
+prim a as = In (Id (Prim a as))
-lam :: [Name] -> Expr -> Expr
-lam as f = In (Lam as f)
+lam :: [String] -> Expr -> Expr
+lam as f = In (Id (Lam as f))
-var :: Name -> Expr
-var a = In (Var a )
+var :: String -> Expr
+var a = In (Id (Var a))
-name :: Name -> Expr -> Expr
-name a b = In (Name a b )
+def :: String -> Expr -> Expr
+def a b = In (Id (Def a b))
more :: [Expr] -> Expr
-more as = In (More as )
+more as = In (Id (More as))
-instance Show (f (Fix f)) => Show (Fix f) where
- show (In f) = "(" ++ show f ++ ")"
+-- MuRef instances for Data.Reify.
-instance Traversable a => R.MuRef (Fix a) where
- type R.DeRef (Fix a) = a
- mapDeRef f = traverse f . out
+instance Traversable f => R.MuRef (FixA Id f) where
+ type R.DeRef (Fix f) = f
+ mapDeRef f = traverse f . unId . out
data Graph = Graph
{ nodes :: Map String (ExprF String)
@@ -73,22 +72,24 @@ data Graph = Graph
foldGraph
:: (Graph -> [a] -> [a] -> String -> String -> String -> a)
-> (Graph -> String -> String -> a)
+ -> (Graph -> String -> String -> [String] -> a)
-> (Graph -> [a] -> String -> [String] -> String -> a)
-> (Graph -> String -> String -> a)
-> (Graph -> [a] -> String -> String -> String -> a)
-> (Graph -> [[a]] -> String -> [String] -> a)
-> Graph
-> [a]
-foldGraph f0 f1 f2 f3 f4 f5 g@(Graph m r) = evalState (folder (r, r `from` m)) Set.empty
+foldGraph f0 f1 f2 f3 f4 f5 f6 g@(Graph m r) = evalState (folder (r, r `from` m)) Set.empty
where
folder (i, term) =
case term of
- App f b -> rec f >>= \r0 -> rec b >>= \r1 -> pure [f0 g r0 r1 i f b ]
- Prim s -> pure [f1 g i s ]
- Lam v b -> rec b >>= \r0 -> pure [f2 g r0 i v b ]
- Var v -> pure [f3 g i v ]
- More as -> mapM rec as >>= \rs -> pure [f5 g rs i as ]
- Name n b -> rec b >>= \r0 -> pure [f4 g r0 i n b ]
+ App f b -> rec f >>= \r0 -> rec b >>= \r1 -> pure [f0 g r0 r1 i f b ]
+ Con s -> pure [f1 g i s ]
+ Prim s vs -> pure [f2 g i s vs ]
+ Lam v b -> rec b >>= \r0 -> pure [f3 g r0 i v b ]
+ Var v -> pure [f4 g i v ]
+ More as -> mapM rec as >>= \rs -> pure [f6 g rs i as ]
+ Def n b -> rec b >>= \r0 -> pure [f5 g r0 i n b ]
from f = fromMaybe (error "internal error in foldGraph") . lookup f
rec k =
do v <- gets (Set.member k)
@@ -0,0 +1,15 @@
+module Compiler.CSE (commonSubExpressionElimination, reifyGraphA) where
+
+import Compiler.Raw
+import Control.Arrow
+import Control.Category
+import Data.Reify.Graph.CSE
+import Prelude hiding ((.), id)
+import qualified Data.Reify as R
+
+reifyGraphA :: R.MuRef a => Kleisli IO a (R.Graph (R.DeRef a))
+reifyGraphA = Kleisli R.reifyGraph
+
+commonSubExpressionElimination :: Kleisli IO Expr (R.Graph ExprF)
+commonSubExpressionElimination = arr cse . Kleisli R.reifyGraph
+
File renamed without changes.
File renamed without changes.
@@ -0,0 +1,28 @@
+module Compiler.FreeVars (FreeVarA (..), ExprFV, annotateWithFreeVars) where
+
+import Compiler.Raw
+import Control.Arrow hiding (app)
+import Data.Set hiding (map)
+
+data FreeVarA f a = FreeVarA { free :: Set String , expr :: f a }
+
+type ExprFV = FixA FreeVarA ExprF
+
+annotateWithFreeVars :: Arrow (~>) => Expr ~> FixA FreeVarA ExprF
+annotateWithFreeVars = arr (ann . unId . out)
+ where
+
+ -- traversal
+ ann (App l r) = ae (union (fv l') (fv r')) (App l' r') where l' = rec l; r' = rec r
+ ann (Con c) = ae (empty) (Con c )
+ ann (Prim s vs) = ae (fromList vs) (Prim s vs )
+ ann (Lam x e) = ae (difference (fv e') (fromList x)) (Lam x e' ) where e' = rec e
+ ann (Var v) = ae (singleton v) (Var v )
+ ann (Def n e) = ae (fv e') (Def n e' ) where e' = rec e
+ ann (More es) = ae (unions (map fv es')) (More es' ) where es' = map rec es
+
+ -- helpers
+ rec = annotateWithFreeVars
+ ae vs e = In (FreeVarA vs e)
+ fv = free . out
+
@@ -0,0 +1,13 @@
+module Compiler.Inliner where
+
+import qualified Data.Map as Map
+import Data.List
+import Compiler.Raw
+import Control.Arrow
+
+inliner (Graph vm x) =
+ let uses = map snd . filter ((<=1) . fst) . map (length &&& head) . group . sort . concatMap undefined . Map.elems $ vm :: [String]
+ rep from to x = if x == from then to else x
+ once (f, t) = Map.map (fmap (rep f t))
+ in Graph (foldr once vm uses) x
+
@@ -17,7 +17,7 @@ Lambda-lifting gives us a list of definitions. The |Expr| datatype doesn't conta
The |freeVars| function will annotate every expression with its variables. The type of such an annotated expression is:
-> newtype AnnExpr a = AnnExpr {unAnn :: (a, ExprF (AnnExpr a))} deriving Show
+> newtype AnnExpr a = AnnExpr {unAnn :: (a, ExprF (AnnExpr a))} -- deriving Show
These are some smart constructor/destructor functions:
@@ -38,14 +38,14 @@ These are some smart constructor/destructor functions:
> freeVars' (App l r) = let l' = freeVars l
> r' = freeVars r
> in ae (S.union (fv l') (fv r')) (App l' r')
-> freeVars' (Prim s) = ae S.empty (Prim s)
+> freeVars' (Con c) = ae S.empty (Con c)
+> freeVars' (Prim s vs) = ae (S.fromList vs) (Prim s vs)
> freeVars' (Lam x expr) = let expr' = freeVars expr
> in ae (S.difference (fv expr') (S.fromList x)) (Lam x expr')
> freeVars' (Var v) = ae (S.singleton v) (Var v)
> freeVars' (Name nm expr) = mapVal (Name nm) (freeVars expr)
> freeVars' (More _) = error "no idea"
-
> mapVal :: (AnnExpr t -> ExprF (AnnExpr t)) -> AnnExpr t -> AnnExpr t
> mapVal f (AnnExpr (a, e)) = ae a (f (AnnExpr (a, e)))
@@ -56,7 +56,8 @@ abstractions for all free variables in |e| (and an |App| as well).
> abstract = f
> where
> f (AnnExpr (_, (App l r))) = app (abstract l) (abstract r)
-> f (AnnExpr (_, (Prim s))) = prim s
+> f (AnnExpr (_, (Con c))) = con c
+> f (AnnExpr (_, (Prim s vs))) = prim s vs -- TODO ???
> f (AnnExpr (a, (Lam x expr))) = let frees = S.toList a
> in addVars (In $ Lam (frees ++ x) (abstract expr)) frees
> f (AnnExpr (_, (Var v))) = var v
@@ -83,9 +84,12 @@ collectSCs lifts all the lambdas to supercombinators (as described in the paper)
> collectSCs' (App l r) = do l' <- collectSCs' (out l)
> r' <- collectSCs' (out r)
> return (app l' r')
-> collectSCs' (Prim s) = do nm <- freshName -- to indirect
-> write nm (In $ Prim s)
-> return $ In $ Var nm
+> collectSCs' (Con c) = do return (con c) -- nm <- freshName -- to indirect
+> -- write nm (In $ Con c)
+> -- return $ In $ Var nm
+> collectSCs' (Prim s vs) = do return (prim s vs) -- nm <- freshName -- to indirect
+> -- write nm (In $ Prim s)
+> -- return $ In $ Var nm
> collectSCs' (Lam x expr) = do expr' <- collectSCs' (out expr)
> nm <- freshName
> write nm (In $ Lam x expr')
File renamed without changes.
Oops, something went wrong.

0 comments on commit d28bdc0

Please sign in to comment.