@@ -0,0 +1,129 @@
1+module IRTS.Simplified where
2+
3+import IRTS.Lang
4+import Core.TT
5+import Data.Maybe
6+import Control.Monad.State
7+
8+-- Simplified expressions, where functions/constructors can only be applied
9+-- to variables
10+
11+data SExp = SV LVar
12+ | SApp Bool Name [LVar]
13+ | SLet Name SExp SExp
14+ | SCon Int Name [LVar]
15+ | SCase LVar [SAlt]
16+ | SConst Const
17+ | SOp PrimFn [LVar]
18+ deriving Show
19+
20+data SAlt = SConCase Int Name [Name] SExp
21+ | SConstCase Const SExp
22+ | SDefaultCase SExp
23+ deriving Show
24+
25+data SDecl = SFun Name [Name] SExp
26+ deriving Show
27+
28+hvar :: State Int Int
29+hvar = do h <- get
30+ put (h + 1)
31+ return h
32+
33+simplify :: LExp -> State Int SExp
34+simplify (LV (Loc i)) = return (SV (Loc i))
35+simplify (LV x) = return (SV x)
36+simplify (LApp tc n args) = do args' <- mapM sVar args
37+ mkapp (SApp tc n) args'
38+simplify (LLet n v e) = do v' <- simplify v
39+ e' <- simplify e
40+ return (SLet n v' e')
41+simplify (LCon i n args) = do args' <- mapM sVar args
42+ mkapp (SCon i n) args'
43+simplify (LCase e alts) = do v <- sVar e
44+ alts' <- mapM sAlt alts
45+ case v of
46+ (x, Nothing) -> return (SCase x alts')
47+ (Glob x, Just e) ->
48+ return (SLet x e (SCase (Glob x) alts'))
49+simplify (LConst c) = return (SConst c)
50+simplify (LOp p args) = do args' <- mapM sVar args
51+ mkapp (SOp p) args'
52+
53+sVar (LV x) = return (x, Nothing)
54+sVar e = do e' <- simplify e
55+ i <- hvar
56+ return (Glob (MN i "R"), Just e')
57+
58+mkapp f args = mkapp' f args [] where
59+ mkapp' f [] args = return $ f (reverse args)
60+ mkapp' f ((x, Nothing) : xs) args = mkapp' f xs (x : args)
61+ mkapp' f ((Glob x, Just e) : xs) args
62+ = do sc <- mkapp' f xs (Glob x : args)
63+ return (SLet x e sc)
64+
65+sAlt (LConCase i n args e) = do e' <- simplify e
66+ return (SConCase i n args e')
67+sAlt (LConstCase c e) = do e' <- simplify e
68+ return (SConstCase c e')
69+sAlt (LDefaultCase e) = do e' <- simplify e
70+ return (SDefaultCase e')
71+
72+checkDefs :: LDefs -> [(Name, LDecl)] -> TC [(Name, SDecl)]
73+checkDefs ctxt [] = return []
74+checkDefs ctxt (con@(n, LConstructor _ _ _) : xs)
75+ = do xs' <- checkDefs ctxt xs
76+ return xs'
77+checkDefs ctxt ((n, LFun n' args exp) : xs)
78+ = do let sexp = evalState (simplify exp) 0
79+ exp' <- scopecheck ctxt (zip args [0..]) sexp
80+ xs' <- checkDefs ctxt xs
81+ return ((n, SFun n' args exp') : xs')
82+
83+scopecheck :: LDefs -> [(Name, Int)] -> SExp -> TC SExp
84+scopecheck ctxt env tm = sc env tm where
85+ sc env (SV (Glob n))
86+ = case lookup n (reverse env) of -- most recent first
87+ Just i -> return (SV (Loc i))
88+ Nothing -> case lookupCtxt Nothing n ctxt of
89+ [LConstructor _ i ar] ->
90+ if ar == 0 then return (SCon i n [])
91+ else fail $ "Codegen error: Constructor " ++ show n ++
92+ " has arity " ++ show ar
93+ [_] -> return (SV (Glob n))
94+ [] -> fail $ "Codegen error: No such variable " ++ show n
95+ sc env (SApp tc f args)
96+ = do case lookupCtxt Nothing f ctxt of
97+ [LConstructor n tag ar] ->
98+ if (ar == length args)
99+ then return $ SCon tag n args
100+ else fail $ "Codegen error: Constructor " ++ show f ++
101+ " has arity " ++ show ar
102+ [_] -> return $ SApp tc f args
103+ [] -> fail $ "Codegen error: No such variable " ++ show f
104+ sc env (SCase e alts)
105+ = do alts' <- mapM (scalt env) alts
106+ return (SCase e alts')
107+ sc env (SLet n v e)
108+ = do v' <- sc env v
109+ e' <- sc (env ++ [(n, length env)]) e
110+ return (SLet n v' e')
111+ sc env (SOp prim args)
112+ = do return (SOp prim args)
113+ sc env x = return x
114+
115+ scalt env (SConCase i n args e)
116+ = do let env' = env ++ zip args [length env..]
117+ tag <- case lookupCtxt Nothing n ctxt of
118+ [LConstructor _ i ar] ->
119+ if (length args == ar) then return i
120+ else fail $ "Codegen error: Constructor " ++ show n ++
121+ " has arity " ++ show ar
122+ _ -> fail $ "Codegen error: No constructor " ++ show n
123+ e' <- sc env' e
124+ return (SConCase tag n args e')
125+ scalt env (SConstCase c e) = do e' <- sc env e
126+ return (SConstCase c e')
127+ scalt env (SDefaultCase e) = do e' <- sc env e
128+ return (SDefaultCase e')
129+