Permalink
Browse files

New datatype for defunctionalised programs

...so that we can't make something ill formed by accident
  • Loading branch information...
1 parent bfa8cc2 commit 783d45fa25c2c61ace800c80bc3a7e1dd418a5be Edwin Brady committed Oct 5, 2012
Showing with 123 additions and 75 deletions.
  1. +92 −44 src/IRTS/Defunctionalise.hs
  2. +31 −31 src/IRTS/Simplified.hs
View
136 src/IRTS/Defunctionalise.hs
@@ -7,7 +7,30 @@ import Debug.Trace
import Data.Maybe
import Data.List
-defunctionalise :: Int -> LDefs -> LDefs
+data DExp = DV LVar
+ | DApp Bool Name [DExp] -- True = tail call
+ | DLet Name DExp DExp -- name just for pretty printing
+ | DLam [Name] DExp -- lambda, lifted out before compiling
+ | DC Int Name [DExp]
+ | DCase DExp [DAlt]
+ | DConst Const
+ | DForeign FLang FType String [(FType, DExp)]
+ | DOp PrimFn [DExp]
+ | DError String
+ deriving Eq
+
+data DAlt = DConCase Int Name [Name] DExp
+ | DConstCase Const DExp
+ | DDefaultCase DExp
+ deriving (Show, Eq)
+
+data DDecl = DFun Name [Name] DExp -- name, arg names, definition
+ | DConstructor Name Int Int -- constructor name, tag, arity
+ deriving (Show, Eq)
+
+type DDefs = Ctxt DDecl
+
+defunctionalise :: Int -> LDefs -> DDefs
defunctionalise nexttag defs
= let all = toAlist defs
-- sort newcons so that EVAL and APPLY cons get sequential tags
@@ -36,57 +59,58 @@ getFn xs = mapMaybe fnData xs
-- 7 Wrap unknown applications (i.e. applications of local variables) in chains of APPLY
-- 8 Add explicit EVAL to case, primitives, and foreign calls
-addApps :: LDefs -> (Name, LDecl) -> (Name, LDecl)
-addApps defs o@(n, LConstructor _ _ _) = o
-addApps defs (n, LFun _ args e) = (n, LFun n args (aa args e))
+addApps :: LDefs -> (Name, LDecl) -> (Name, DDecl)
+addApps defs o@(n, LConstructor _ t a) = (n, DConstructor n t a)
+addApps defs (n, LFun _ args e) = (n, DFun n args (aa args e))
where
- aa env (LV (Glob n)) | n `elem` env = LV (Glob n)
+ aa :: [Name] -> LExp -> DExp
+ aa env (LV (Glob n)) | n `elem` env = DV (Glob n)
| otherwise = aa env (LApp False (LV (Glob n)) [])
-- aa env e@(LApp tc (MN 0 "EVAL") [a]) = e
aa env (LApp tc (LV (Glob n)) args)
= let args' = map (aa env) args in
case lookupCtxt Nothing n defs of
- [LConstructor _ i ar] -> LApp tc (LV (Glob n)) args'
+ [LConstructor _ i ar] -> DApp tc n args'
[LFun _ as _] -> let arity = length as in
fixApply tc n args' arity
- [] -> chainAPPLY (LV (Glob n)) args'
+ [] -> chainAPPLY (DV (Glob n)) args'
aa env (LLazyApp n args)
= let args' = map (aa env) args in
case lookupCtxt Nothing n defs of
- [LConstructor _ i ar] -> LApp False (LV (Glob n)) args'
+ [LConstructor _ i ar] -> DApp False n args'
[LFun _ as _] -> let arity = length as in
fixLazyApply n args' arity
- [] -> chainAPPLY (LV (Glob n)) args'
+ [] -> chainAPPLY (DV (Glob n)) args'
aa env (LForce e) = eEVAL (aa env e)
- aa env (LLet n v sc) = LLet n (aa env v) (aa (n : env) sc)
- aa env (LCon i n args) = LCon i n (map (aa env) args)
- aa env (LCase e alts) = LCase (eEVAL (aa env e)) (map (aaAlt env) alts)
- aa env (LConst c) = LConst c
- aa env (LForeign l t n args) = LForeign l t n (map (aaF env) args)
- aa env (LOp LFork args) = LOp LFork (map (aa env) args)
- aa env (LOp f args) = LOp f (map (eEVAL . (aa env)) args)
- aa env (LError e) = LError e
+ aa env (LLet n v sc) = DLet n (aa env v) (aa (n : env) sc)
+ aa env (LCon i n args) = DC i n (map (aa env) args)
+ aa env (LCase e alts) = DCase (eEVAL (aa env e)) (map (aaAlt env) alts)
+ aa env (LConst c) = DConst c
+ aa env (LForeign l t n args) = DForeign l t n (map (aaF env) args)
+ aa env (LOp LFork args) = DOp LFork (map (aa env) args)
+ aa env (LOp f args) = DOp f (map (eEVAL . (aa env)) args)
+ aa env (LError e) = DError e
aaF env (t, e) = (t, eEVAL (aa env e))
- aaAlt env (LConCase i n args e) = LConCase i n args (aa (args ++ env) e)
- aaAlt env (LConstCase c e) = LConstCase c (aa env e)
- aaAlt env (LDefaultCase e) = LDefaultCase (aa env e)
+ aaAlt env (LConCase i n args e) = DConCase i n args (aa (args ++ env) e)
+ aaAlt env (LConstCase c e) = DConstCase c (aa env e)
+ aaAlt env (LDefaultCase e) = DDefaultCase (aa env e)
fixApply tc n args ar
- | length args == ar = LApp tc (LV (Glob n)) args
- | length args < ar = LApp tc (LV (Glob (mkUnderCon n (ar - length args)))) args
- | length args > ar = chainAPPLY (LApp tc (LV (Glob n)) (take ar args)) (drop ar args)
+ | length args == ar = DApp tc n args
+ | length args < ar = DApp tc (mkUnderCon n (ar - length args)) args
+ | length args > ar = chainAPPLY (DApp tc n (take ar args)) (drop ar args)
fixLazyApply n args ar
- | length args == ar = LApp False (LV (Glob (mkFnCon n))) args
- | length args < ar = LApp False (LV (Glob (mkUnderCon n (ar - length args)))) args
- | length args > ar = chainAPPLY (LApp False (LV (Glob n)) (take ar args)) (drop ar args)
+ | length args == ar = DApp False (mkFnCon n) args
+ | length args < ar = DApp False (mkUnderCon n (ar - length args)) args
+ | length args > ar = chainAPPLY (DApp False n (take ar args)) (drop ar args)
chainAPPLY f [] = f
- chainAPPLY f (a : as) = chainAPPLY (LApp False (LV (Glob (MN 0 "APPLY"))) [f, a]) as
+ chainAPPLY f (a : as) = chainAPPLY (DApp False (MN 0 "APPLY") [f, a]) as
-eEVAL x = LApp False (LV (Glob (MN 0 "EVAL"))) [x]
+eEVAL x = DApp False (MN 0 "EVAL") [x]
data EvalApply a = EvalCase a
| ApplyCase a
@@ -95,44 +119,44 @@ data EvalApply a = EvalCase a
-- For a function name, generate a list of
-- data constuctors, and whether to handle them in EVAL or APPLY
-toCons :: (Name, Int) -> [(Name, Int, EvalApply LAlt)]
+toCons :: (Name, Int) -> [(Name, Int, EvalApply DAlt)]
toCons (n, i)
= (mkFnCon n, i,
- EvalCase (LConCase (-1) (mkFnCon n) (take i (genArgs 0))
- (eEVAL (LApp False (LV (Glob n)) (map (LV . Glob) (take i (genArgs 0)))))))
+ EvalCase (DConCase (-1) (mkFnCon n) (take i (genArgs 0))
+ (eEVAL (DApp False n (map (DV . Glob) (take i (genArgs 0)))))))
: mkApplyCase n 0 i
mkApplyCase fname n ar | n == ar = []
mkApplyCase fname n ar
= let nm = mkUnderCon fname (ar - n) in
- (nm, n, ApplyCase (LConCase (-1) nm (take n (genArgs 0))
- (LApp False (LV (Glob (mkUnderCon fname (ar - (n + 1)))))
- (map (LV . Glob) (take n (genArgs 0) ++
+ (nm, n, ApplyCase (DConCase (-1) nm (take n (genArgs 0))
+ (DApp False (mkUnderCon fname (ar - (n + 1)))
+ (map (DV . Glob) (take n (genArgs 0) ++
[MN 0 "arg"])))))
: mkApplyCase fname (n + 1) ar
-mkEval :: [(Name, Int, EvalApply LAlt)] -> (Name, LDecl)
-mkEval xs = (MN 0 "EVAL", LFun (MN 0 "EVAL") [MN 0 "arg"]
- (LCase (LV (Glob (MN 0 "arg")))
+mkEval :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
+mkEval xs = (MN 0 "EVAL", DFun (MN 0 "EVAL") [MN 0 "arg"]
+ (DCase (DV (Glob (MN 0 "arg")))
(mapMaybe evalCase xs ++
- [LDefaultCase (LV (Glob (MN 0 "arg")))])))
+ [DDefaultCase (DV (Glob (MN 0 "arg")))])))
where
evalCase (n, t, EvalCase x) = Just x
evalCase _ = Nothing
-mkApply :: [(Name, Int, EvalApply LAlt)] -> (Name, LDecl)
-mkApply xs = (MN 0 "APPLY", LFun (MN 0 "APPLY") [MN 0 "fn", MN 0 "arg"]
- (LCase (LApp False (LV (Glob (MN 0 "EVAL")))
- [LV (Glob (MN 0 "fn"))])
+mkApply :: [(Name, Int, EvalApply DAlt)] -> (Name, DDecl)
+mkApply xs = (MN 0 "APPLY", DFun (MN 0 "APPLY") [MN 0 "fn", MN 0 "arg"]
+ (DCase (DApp False (MN 0 "EVAL")
+ [DV (Glob (MN 0 "fn"))])
(mapMaybe applyCase xs)))
where
applyCase (n, t, ApplyCase x) = Just x
applyCase _ = Nothing
-declare :: Int -> [(Name, Int, EvalApply LAlt)] -> [(Name, LDecl)]
+declare :: Int -> [(Name, Int, EvalApply DAlt)] -> [(Name, DDecl)]
declare t xs = dec' t xs [] where
dec' t [] acc = reverse acc
- dec' t ((n, ar, _) : xs) acc = dec' (t + 1) xs ((n, LConstructor n t ar) : acc)
+ dec' t ((n, ar, _) : xs) acc = dec' (t + 1) xs ((n, DConstructor n t ar) : acc)
genArgs i = MN i "P_c" : genArgs (i + 1)
@@ -141,3 +165,27 @@ mkFnCon n = MN 0 ("P_" ++ show n)
mkUnderCon n 0 = n
mkUnderCon n missing = MN missing ("U_" ++ show n)
+instance Show DExp where
+ show e = show' [] e where
+ show' env (DV (Loc i)) = env!!i
+ show' env (DV (Glob n)) = show n
+ show' env (DApp _ e args) = show e ++ "(" ++
+ showSep ", " (map (show' env) args) ++")"
+ show' env (DLet n v e) = "let " ++ show n ++ " = " ++ show' env v ++ " in " ++
+ show' (env ++ [show n]) e
+ show' env (DLam args e) = "\\ " ++ showSep "," (map show args) ++ " => " ++
+ show' (env ++ (map show args)) e
+ show' env (DC i n args) = show n ++ ")" ++ showSep ", " (map (show' env) args) ++ ")"
+ show' env (DCase e alts) = "case " ++ show' env e ++ " of {\n\t" ++
+ showSep "\n\t| " (map (showAlt env) alts)
+ show' env (DConst c) = show c
+ show' env (DForeign lang ty n args)
+ = "foreign " ++ n ++ "(" ++ showSep ", " (map (show' env) (map snd args)) ++ ")"
+ show' env (DOp f args) = show f ++ "(" ++ showSep ", " (map (show' env) args) ++ ")"
+ show' env (DError str) = "error " ++ show str
+
+ showAlt env (DConCase _ n args e)
+ = show n ++ "(" ++ showSep ", " (map show args) ++ ") => "
+ ++ show' env e
+ showAlt env (DConstCase c e) = show c ++ " => " ++ show' env e
+ showAlt env (DDefaultCase e) = "_ => " ++ show' env e
View
62 src/IRTS/Simplified.hs
@@ -1,6 +1,7 @@
module IRTS.Simplified where
import IRTS.Lang
+import IRTS.Defunctionalise
import Core.TT
import Data.Maybe
import Control.Monad.State
@@ -27,51 +28,50 @@ data SAlt = SConCase Int Int Name [Name] SExp
data SDecl = SFun Name [Name] Int SExp
deriving Show
-hvar :: State (LDefs, Int) Int
+hvar :: State (DDefs, Int) Int
hvar = do (l, h) <- get
put (l, h + 1)
return h
-ldefs :: State (LDefs, Int) LDefs
+ldefs :: State (DDefs, Int) DDefs
ldefs = do (l, h) <- get
return l
-simplify :: Bool -> LExp -> State (LDefs, Int) SExp
-simplify tl (LV (Loc i)) = return (SV (Loc i))
-simplify tl (LV (Glob x))
+simplify :: Bool -> DExp -> State (DDefs, Int) SExp
+simplify tl (DV (Loc i)) = return (SV (Loc i))
+simplify tl (DV (Glob x))
= do ctxt <- ldefs
case lookupCtxt Nothing x ctxt of
- [LConstructor _ t 0] -> return $ SCon t x []
+ [DConstructor _ t 0] -> return $ SCon t x []
_ -> return $ SV (Glob x)
-simplify tl (LApp tc (LV (Glob n)) args)
- = do args' <- mapM sVar args
+simplify tl (DApp tc n args) = do args' <- mapM sVar args
mkapp (SApp (tl || tc) n) args'
-simplify tl (LForeign lang ty fn args)
+simplify tl (DForeign lang ty fn args)
= do args' <- mapM sVar (map snd args)
let fargs = zip (map fst args) args'
mkfapp (SForeign lang ty fn) fargs
-simplify tl (LLet n v e) = do v' <- simplify False v
+simplify tl (DLet n v e) = do v' <- simplify False v
e' <- simplify tl e
return (SLet (Glob n) v' e')
-simplify tl (LCon i n args) = do args' <- mapM sVar args
- mkapp (SCon i n) args'
-simplify tl (LCase e alts) = do v <- sVar e
+simplify tl (DC i n args) = do args' <- mapM sVar args
+ mkapp (SCon i n) args'
+simplify tl (DCase e alts) = do v <- sVar e
alts' <- mapM (sAlt tl) alts
case v of
(x, Nothing) -> return (SCase x alts')
(Glob x, Just e) ->
return (SLet (Glob x) e (SCase (Glob x) alts'))
-simplify tl (LConst c) = return (SConst c)
-simplify tl (LOp p args) = do args' <- mapM sVar args
+simplify tl (DConst c) = return (SConst c)
+simplify tl (DOp p args) = do args' <- mapM sVar args
mkapp (SOp p) args'
-simplify tl (LError str) = return $ SError str
+simplify tl (DError str) = return $ SError str
-sVar (LV (Glob x))
+sVar (DV (Glob x))
= do ctxt <- ldefs
case lookupCtxt Nothing x ctxt of
- [LConstructor _ t 0] -> sVar (LCon t x [])
+ [DConstructor _ t 0] -> sVar (DC t x [])
_ -> return (Glob x, Nothing)
-sVar (LV x) = return (x, Nothing)
+sVar (DV x) = return (x, Nothing)
sVar e = do e' <- simplify False e
i <- hvar
return (Glob (MN i "R"), Just e')
@@ -90,19 +90,19 @@ mkfapp f args = mkapp' f args [] where
= do sc <- mkapp' f xs ((ty, x) : args)
return (SLet x e sc)
-sAlt tl (LConCase i n args e) = do e' <- simplify tl e
+sAlt tl (DConCase i n args e) = do e' <- simplify tl e
return (SConCase (-1) i n args e')
-sAlt tl (LConstCase c e) = do e' <- simplify tl e
+sAlt tl (DConstCase c e) = do e' <- simplify tl e
return (SConstCase c e')
-sAlt tl (LDefaultCase e) = do e' <- simplify tl e
+sAlt tl (DDefaultCase e) = do e' <- simplify tl e
return (SDefaultCase e')
-checkDefs :: LDefs -> [(Name, LDecl)] -> TC [(Name, SDecl)]
+checkDefs :: DDefs -> [(Name, DDecl)] -> TC [(Name, SDecl)]
checkDefs ctxt [] = return []
-checkDefs ctxt (con@(n, LConstructor _ _ _) : xs)
+checkDefs ctxt (con@(n, DConstructor _ _ _) : xs)
= do xs' <- checkDefs ctxt xs
return xs'
-checkDefs ctxt ((n, LFun n' args exp) : xs)
+checkDefs ctxt ((n, DFun n' args exp) : xs)
= do let sexp = evalState (simplify True exp) (ctxt, 0)
(exp', locs) <- runStateT (scopecheck ctxt (zip args [0..]) sexp) (length args)
xs' <- checkDefs ctxt xs
@@ -111,13 +111,13 @@ checkDefs ctxt ((n, LFun n' args exp) : xs)
lvar v = do i <- get
put (max i v)
-scopecheck :: LDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp
+scopecheck :: DDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp
scopecheck ctxt env tm = sc env tm where
sc env (SV (Glob n)) =
case lookup n (reverse env) of -- most recent first
Just i -> do lvar i; return (SV (Loc i))
Nothing -> case lookupCtxt Nothing n ctxt of
- [LConstructor _ i ar] ->
+ [DConstructor _ i ar] ->
if True -- ar == 0
then return (SCon i n [])
else fail $ "Codegen error: Constructor " ++ show n ++
@@ -127,7 +127,7 @@ scopecheck ctxt env tm = sc env tm where
sc env (SApp tc f args)
= do args' <- mapM (scVar env) args
case lookupCtxt Nothing f ctxt of
- [LConstructor n tag ar] ->
+ [DConstructor n tag ar] ->
if True -- (ar == length args)
then return $ SCon tag n args'
else fail $ "Codegen error: Constructor " ++ show f ++
@@ -141,7 +141,7 @@ scopecheck ctxt env tm = sc env tm where
sc env (SCon tag f args)
= do args' <- mapM (scVar env) args
case lookupCtxt Nothing f ctxt of
- [LConstructor n tag ar] ->
+ [DConstructor n tag ar] ->
if True -- (ar == length args)
then return $ SCon tag n args'
else fail $ "Codegen error: Constructor " ++ show f ++
@@ -166,7 +166,7 @@ scopecheck ctxt env tm = sc env tm where
case lookup n (reverse env) of -- most recent first
Just i -> do lvar i; return (Loc i)
Nothing -> case lookupCtxt Nothing n ctxt of
- [LConstructor _ i ar] ->
+ [DConstructor _ i ar] ->
fail $ "Codegen error : can't pass constructor here"
[_] -> return (Glob n)
[] -> fail $ "Codegen error: No such variable " ++ show n
@@ -175,7 +175,7 @@ scopecheck ctxt env tm = sc env tm where
scalt env (SConCase _ i n args e)
= do let env' = env ++ zip args [length env..]
tag <- case lookupCtxt Nothing n ctxt of
- [LConstructor _ i ar] ->
+ [DConstructor _ i ar] ->
if True -- (length args == ar)
then return i
else fail $ "Codegen error: Constructor " ++ show n ++

0 comments on commit 783d45f

Please sign in to comment.