1module IRTS.Simplified where
6import Control.Monad.State
8-- Simplified expressions, where functions/constructors can only be applied
12 | SApp Bool Name [LVar]
14 | SCon Int Name [LVar]
17 | SForeign FLang FType String [(FType, LVar)]
22data SAlt = SConCase Int Int Name [Name] SExp
23 | SConstCase Const SExp
27data SDecl = SFun Name [Name] Int SExp
30hvar :: State (LDefs, Int) Int
31hvar = do (l, h) <- get
35ldefs :: State (LDefs, Int) LDefs
36ldefs = do (l, h) <- get
39simplify :: Bool -> LExp -> State (LDefs, Int) SExp
40simplify tl (LV (Loc i)) = return (SV (Loc i))
41simplify tl (LV (Glob x))
43 case lookupCtxt Nothing x ctxt of
44 [LConstructor _ t 0] -> return $ SCon t x []
45 _ -> return $ SV (Glob x)
46simplify tl (LApp tc (LV (Glob n)) args)
47 = do args' <- mapM sVar args
48 mkapp (SApp (tl || tc) n) args'
49simplify tl (LForeign lang ty fn args)
50 = do args' <- mapM sVar (map snd args)
51 let fargs = zip (map fst args) args'
52 mkfapp (SForeign lang ty fn) fargs
53simplify tl (LLet n v e) = do v' <- simplify False v
55 return (SLet (Glob n) v' e')
56simplify tl (LCon i n args) = do args' <- mapM sVar args
57 mkapp (SCon i n) args'
58simplify tl (LCase e alts) = do v <- sVar e
59 alts' <- mapM (sAlt tl) alts
61 (x, Nothing) -> return (SCase x alts')
63 return (SLet (Glob x) e (SCase (Glob x) alts'))
64simplify tl (LConst c) = return (SConst c)
65simplify tl (LOp p args) = do args' <- mapM sVar args
67simplify tl (LError str) = return $ SError str
71 case lookupCtxt Nothing x ctxt of
72 [LConstructor _ t 0] -> sVar (LCon t x [])
73 _ -> return (Glob x, Nothing)
74sVar (LV x) = return (x, Nothing)
75sVar e = do e' <- simplify False e
77 return (Glob (MN i "R"), Just e')
79mkapp f args = mkapp' f args [] where
80 mkapp' f [] args = return $ f (reverse args)
81 mkapp' f ((x, Nothing) : xs) args = mkapp' f xs (x : args)
82 mkapp' f ((x, Just e) : xs) args
83 = do sc <- mkapp' f xs (x : args)
86mkfapp f args = mkapp' f args [] where
87 mkapp' f [] args = return $ f (reverse args)
88 mkapp' f ((ty, (x, Nothing)) : xs) args = mkapp' f xs ((ty, x) : args)
89 mkapp' f ((ty, (x, Just e)) : xs) args
90 = do sc <- mkapp' f xs ((ty, x) : args)
93sAlt tl (LConCase i n args e) = do e' <- simplify tl e
94 return (SConCase (-1) i n args e')
95sAlt tl (LConstCase c e) = do e' <- simplify tl e
96 return (SConstCase c e')
97sAlt tl (LDefaultCase e) = do e' <- simplify tl e
98 return (SDefaultCase e')
100checkDefs :: LDefs -> [(Name, LDecl)] -> TC [(Name, SDecl)]
101checkDefs ctxt [] = return []
102checkDefs ctxt (con@(n, LConstructor _ _ _) : xs)
103 = do xs' <- checkDefs ctxt xs
105checkDefs ctxt ((n, LFun n' args exp) : xs)
106 = do let sexp = evalState (simplify True exp) (ctxt, 0)
107 (exp', locs) <- runStateT (scopecheck ctxt (zip args [0..]) sexp) (length args)
108 xs' <- checkDefs ctxt xs
109 return ((n, SFun n' args ((locs + 1) - length args) exp') : xs')
114scopecheck :: LDefs -> [(Name, Int)] -> SExp -> StateT Int TC SExp
115scopecheck ctxt env tm = sc env tm where
116 sc env (SV (Glob n)) =
117 case lookup n (reverse env) of -- most recent first
118 Just i -> do lvar i; return (SV (Loc i))
119 Nothing -> case lookupCtxt Nothing n ctxt of
120 [LConstructor _ i ar] ->
122 then return (SCon i n [])
123 else fail $ "Codegen error: Constructor " ++ show n ++
124 " has arity " ++ show ar
125 [_] -> return (SV (Glob n))
126 [] -> fail $ "Codegen error: No such variable " ++ show n
127 sc env (SApp tc f args)
128 = do args' <- mapM (scVar env) args
129 case lookupCtxt Nothing f ctxt of
130 [LConstructor n tag ar] ->
131 if True -- (ar == length args)
132 then return $ SCon tag n args'
133 else fail $ "Codegen error: Constructor " ++ show f ++
134 " has arity " ++ show ar
135 [_] -> return $ SApp tc f args'
136 [] -> fail $ "Codegen error: No such variable " ++ show f
137 sc env (SForeign l ty f args)
138 = do args' <- mapM (\ (t, a) -> do a' <- scVar env a
140 return $ SForeign l ty f args'
141 sc env (SCon tag f args)
142 = do args' <- mapM (scVar env) args
143 case lookupCtxt Nothing f ctxt of
144 [LConstructor n tag ar] ->
145 if True -- (ar == length args)
146 then return $ SCon tag n args'
147 else fail $ "Codegen error: Constructor " ++ show f ++
148 " has arity " ++ show ar
149 _ -> fail $ "Codegen error: No such constructor " ++ show f
150 sc env (SCase e alts)
151 = do e' <- scVar env e
152 alts' <- mapM (scalt env) alts
153 return (SCase e' alts')
154 sc env (SLet (Glob n) v e)
155 = do let env' = env ++ [(n, length env)]
157 n' <- scVar env' (Glob n)
159 return (SLet n' v' e')
160 sc env (SOp prim args)
161 = do args' <- mapM (scVar env) args
162 return (SOp prim args')
166 case lookup n (reverse env) of -- most recent first
167 Just i -> do lvar i; return (Loc i)
168 Nothing -> case lookupCtxt Nothing n ctxt of
169 [LConstructor _ i ar] ->
170 fail $ "Codegen error : can't pass constructor here"
171 [_] -> return (Glob n)
172 [] -> fail $ "Codegen error: No such variable " ++ show n
175 scalt env (SConCase _ i n args e)
176 = do let env' = env ++ zip args [length env..]
177 tag <- case lookupCtxt Nothing n ctxt of
178 [LConstructor _ i ar] ->
179 if True -- (length args == ar)
181 else fail $ "Codegen error: Constructor " ++ show n ++
182 " has arity " ++ show ar
183 _ -> fail $ "Codegen error: No constructor " ++ show n
185 return (SConCase (length env) tag n args e')
186 scalt env (SConstCase c e) = do e' <- sc env e
187 return (SConstCase c e')
188 scalt env (SDefaultCase e) = do e' <- sc env e
189 return (SDefaultCase e')
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list