Permalink
Browse files

Generic closure (without free vars) lifter.

  • Loading branch information...
1 parent 212d070 commit c0cebd07f2fdc35deba2212fefb851647e5ac7a7 Sebastiaan Visser committed Dec 19, 2009
@@ -11,8 +11,8 @@ import Compiler.LiftDefinitions
import Compiler.Raw
import Control.Arrow hiding (app)
import Data.List (intercalate)
-import Data.Map (keys)
-import Data.Set hiding (map)
+import Data.Set hiding (map, insert)
+import qualified Data.Map as M
data FreeVarA f a = FreeVarA { free :: Set String , expr :: f a }
@@ -25,7 +25,7 @@ annotateWithFreeVariables = arr ow
where
-- references to global definitions don't count as free variables.
- globs = fromList (keys (collectDefinitions ex))
+ globs = fromList (M.keys (collectDefinitions ex))
-- traversal function
ann (App l r) = ae (union (fv l') (fv r')) (App l' r') where l' = rec l; r' = rec r
@@ -42,14 +42,14 @@ annotateWithFreeVariables = arr ow
fv = free . out
printDefinitionsWithFreeVariables :: Arrow (~>) => ExprFV ~> String
-printDefinitionsWithFreeVariables = arr tr0
+printDefinitionsWithFreeVariables = arr top
where
- tr0 (In (FreeVarA vf x)) = (if size vf /= 0 then "/* free: " ++ show (toList vf) ++ " */" else "") ++ tr x
- tr (App f e) = tr0 f ++ "(" ++ tr0 e ++ ")"
+ top (In (FreeVarA vf x)) = (if size vf /= 0 then "/* free: " ++ show (toList vf) ++ " */" else "/* 0 */") ++ tr x
+ tr (App f e) = top f ++ "(" ++ top e ++ ")"
tr (Con c) = c
tr (Prim s _) = s
- tr (Lam as e) = "(function (" ++ intercalate ", " as ++ ")" ++ "{ " ++ "return " ++ tr0 e ++ ";" ++ " })"
+ tr (Lam as e) = "(function (" ++ intercalate ", " as ++ ")" ++ "{ " ++ "return " ++ top e ++ ";" ++ " })"
tr (Var v) = v
- tr (Def n e) = n ++ " = " ++ tr0 e
- tr (More es) = intercalate "\n" (map tr0 es)
+ tr (Def n e) = n ++ " = " ++ top e
+ tr (More es) = intercalate "\n" (map top es)
@@ -0,0 +1,38 @@
+module Compiler.LiftClosures where
+
+import Control.Applicative
+import Compiler.FreeVariables
+import Compiler.Generics
+import Compiler.Raw
+import Control.Arrow hiding (app)
+import Control.Monad.State
+import Data.Traversable
+import qualified Data.Set as S
+import qualified Data.Map as M
+
+liftClosures :: Arrow (~>) => ExprFV ~> Expr
+liftClosures = arr (flip evalState (0, M.empty) . collectAll)
+
+collectAll :: ExprFV -> State (Integer, M.Map Integer Expr) Expr
+collectAll (In (FreeVarA vf x)) =
+ if and [S.size vf == 0, liftable x]
+ then do s <- rec x >>= collectSingle
+ return (var ('c': show s))
+ else rec x
+ where rec (Def n d) = do z <- collectAll d
+ mp <- gets snd
+ modify (\(a, _) -> (a, M.empty))
+ return (more (M.elems mp ++ [def n z]))
+ rec e = In . Id <$> traverse collectAll e
+
+collectSingle :: Expr -> State (Integer, M.Map Integer Expr) Integer
+collectSingle e =
+ do modify $ \(i, store) ->
+ let v = i + 1 :: Integer
+ in (v, M.insert v (def ('c':show v) e) store)
+ gets fst
+
+liftable :: ExprF t -> Bool
+liftable (App _ _) = True
+liftable _ = False
+
@@ -35,7 +35,7 @@ collectDefinitions = reduce defs
-- definitions.
liftDefinitions :: Arrow (~>) => Expr ~> Expr
-liftDefinitions = arr (\e -> more (elems (collectDefinitions e) ++ [tr e]))
+liftDefinitions = arr (\e -> more (elems (collectDefinitions e) ++ [def "__main" (tr e)]))
where
tr d@(In (Id (Def _ _))) = d
tr e = inlineDefinitions e
View
@@ -4,6 +4,7 @@ module Compiler.Pipeline where
import Compiler.FreeVariables
import Compiler.Instantiate
import Compiler.LiftDefinitions
+import Compiler.LiftClosures
-- import Compiler.LiftLambdas
import Control.Arrow
import Lang.Value
@@ -13,7 +14,9 @@ compiler = runKleisli
$ instantiateLambas
>>> liftDefinitions
>>> annotateWithFreeVariables
+ >>> liftClosures
-- >>> addLambdaAbstractions
-- >>> collectSuperCombinators
- >>> printDefinitionsWithFreeVariables
+-- >>> printDefinitionsWithFreeVariables
+ >>> printDefinitions
View
@@ -17,12 +17,12 @@ instance (FunC j, ListC j) => Functor j [] where
singleton :: ListC j => j a -> j [a]
singleton a = cons a nil
-(++) :: ListC j => j [a] -> j [a] -> j [a]
-xs ++ ys = list ys cons xs
-
foldr :: (FunC j, ListC j) => (j a -> j b -> j b) -> j b -> j [a] -> j b
foldr f b xs = fix (\r -> lam (list b (\y ys -> f y (r `app` ys)))) `app` xs
+(++) :: (FunC j, ListC j) => j [a] -> j [a] -> j [a]
+xs ++ ys = foldr cons ys xs
+
length :: (FunC j, NumC j, ListC j) => j [a] -> j Num
length = foldr (\_ -> (+1)) 0
View
@@ -9,7 +9,7 @@ jsList :: Js [Num]
jsList = 1 `cons` (2 `cons` (3 `cons` (4 `cons` (5 `cons` (6 `cons` (7 `cons` nil))))))
jsSumList :: Js Num
-jsSumList = sum jsList
+jsSumList = sum (jsList ++ jsList) * sum jsList
jsApp :: Js Num
jsApp = maybe 10 (*2) (just (4 * 3))
View
@@ -1,5 +1,59 @@
-add = (function (v5){ return /* free: ["v5"] */(function (v6){ return /* free: ["v5","v6"] */v5 + v6; }); })
-cons = (function (v1){ return /* free: ["v1"] */(function (v2){ return /* free: ["v1","v2"] */{ head : v1, tail : v2 }; }); })
-fix = (function (v1){ return /* free: ["v1"] */fix = arguments.callee, v1(function (i) { return fix(v1)(i) }); })
-list = (function (v3){ return /* free: ["v3"] */(function (v4){ return /* free: ["v3","v4"] */(function (v5){ return /* free: ["v3","v4","v5"] */v5.nil ? v3 : v4(v5.head)(v5.tail); }); }); })
-fix((function (v1){ return /* free: ["v1"] */(function (v2){ return /* free: ["v1","v2"] *//* free: ["v1"] */list(0)(/* free: ["v1"] */(function (v3){ return /* free: ["v1","v3"] */(function (v4){ return /* free: ["v1","v3","v4"] *//* free: ["v3"] */add(/* free: ["v3"] */v3)(/* free: ["v1","v4"] *//* free: ["v1"] */v1(/* free: ["v4"] */v4)); }); }))(/* free: ["v2"] */v2); }); }))(cons(1)(cons(2)(cons(3)(cons(4)(cons(5)(cons(6)(cons(7)({ nil : 1 }))))))))
+add = (function (v5){ return (function (v6){ return v5 + v6; }); })
+cons = (function (v3){ return (function (v4){ return { head : v3, tail : v4 }; }); })
+fix = (function (v1){ return fix = arguments.callee, v1(function (i) { return fix(v1)(i) }); })
+list = (function (v3){ return (function (v4){ return (function (v5){ return v5.nil ? v3 : v4(v5.head)(v5.tail); }); }); })
+mul = (function (v1){ return (function (v2){ return v1 * v2; }); })
+c1 = list(0)
+c2 = fix((function (v1){ return (function (v2){ return c1((function (v3){ return (function (v4){ return add(v3)(v1(v4)); }); }))(v2); }); }))
+c3 = cons(1)
+c4 = cons(2)
+c5 = cons(3)
+c6 = cons(4)
+c7 = cons(5)
+c8 = cons(6)
+c9 = cons(7)
+c10 = c9({ nil : 1 })
+c11 = c8(c10)
+c12 = c7(c11)
+c13 = c6(c12)
+c14 = c5(c13)
+c15 = c4(c14)
+c16 = c3(c15)
+c17 = list(c16)
+c18 = fix((function (v1){ return (function (v2){ return c17((function (v3){ return (function (v4){ return cons(v3)(v1(v4)); }); }))(v2); }); }))
+c19 = cons(1)
+c20 = cons(2)
+c21 = cons(3)
+c22 = cons(4)
+c23 = cons(5)
+c24 = cons(6)
+c25 = cons(7)
+c26 = c25({ nil : 1 })
+c27 = c24(c26)
+c28 = c23(c27)
+c29 = c22(c28)
+c30 = c21(c29)
+c31 = c20(c30)
+c32 = c19(c31)
+c33 = c18(c32)
+c34 = c2(c33)
+c35 = mul(c34)
+c36 = list(0)
+c37 = fix((function (v1){ return (function (v2){ return c36((function (v3){ return (function (v4){ return add(v3)(v1(v4)); }); }))(v2); }); }))
+c38 = cons(1)
+c39 = cons(2)
+c40 = cons(3)
+c41 = cons(4)
+c42 = cons(5)
+c43 = cons(6)
+c44 = cons(7)
+c45 = c44({ nil : 1 })
+c46 = c43(c45)
+c47 = c42(c46)
+c48 = c41(c47)
+c49 = c40(c48)
+c50 = c39(c49)
+c51 = c38(c50)
+c52 = c37(c51)
+c53 = c35(c52)
+__main = c53

0 comments on commit c0cebd0

Please sign in to comment.