1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
3 Preprocess a module to normalize it in the following ways:
4 (1) Saturate all constructor and primop applications.
5 (2) Arrange that any non-trivial expression of unlifted kind ('#')
6 is turned into the scrutinee of a Case.
7 After these preprocessing steps, Core can be interpreted (or given an operational semantics)
8 ignoring type information almost completely.
23 primArgTys :: Env Var [Ty]
24 primArgTys = efromlist (map f (etolist (venv_ primEnv)))
25 where f (v,t) = (v,atys)
26 where (_,atys,_) = splitTy t
28 prepModule :: Menv -> Module -> Module
29 prepModule globalEnv (Module mn tdefs vdefgs) =
30 Module mn tdefs vdefgs'
33 (_,vdefgs') = foldl prepTopVdefg (eempty,[]) vdefgs
35 prepTopVdefg (venv,vdefgs) vdefg = (venv',vdefgs ++ [vdefg'])
36 where (venv',vdefg') = prepVdefg (venv,eempty) vdefg
38 prepVdefg (env@(venv,_)) (Nonrec(Vdef((Nothing,x),t,e))) =
39 (eextend venv (x,t), Nonrec(Vdef((Nothing,x),t,prepExp env e)))
40 prepVdefg (env@(venv,_)) (Nonrec(Vdef(qx,t,e))) =
41 (venv, Nonrec(Vdef(qx,t,prepExp env e)))
42 prepVdefg (venv,tvenv) (Rec vdefs) =
43 (venv',Rec [ Vdef(qx,t,prepExp (venv',tvenv) e) | Vdef(qx,t,e) <- vdefs])
44 where venv' = foldl eextend venv [(x,t) | Vdef((Nothing,x),t,_) <- vdefs]
46 prepExp _ (Var qv) = Var qv
47 prepExp _ (Dcon qdc) = Dcon qdc
48 prepExp _ (Lit l) = Lit l
49 prepExp env e@(App _ _) = unwindApp env e []
50 prepExp env e@(Appt _ _) = unwindApp env e []
51 prepExp (venv,tvenv) (Lam (Vb vb) e) = Lam (Vb vb) (prepExp (eextend venv vb,tvenv) e)
52 prepExp (venv,tvenv) (Lam (Tb tb) e) = Lam (Tb tb) (prepExp (venv,eextend tvenv tb) e)
53 prepExp env@(venv,tvenv) (Let (Nonrec(Vdef((Nothing,x),t,b))) e)
54 | (kindOfTy tvenv t `eqKind` Kunlifted && suspends b) =
55 -- There are two places where we call the typechecker, one of them
57 -- We need to know the type of the let body in order to construct
59 -- need to extend the env with the let-bound var too!
60 let eTy = typeOfExp (eextend venv (x, t), tvenv) e in
61 Case (prepExp env b) (x,t)
63 [Adefault (prepExp (eextend venv (x,t),tvenv) e)]
64 prepExp (venv,tvenv) (Let vdefg e) = Let vdefg' (prepExp (venv',tvenv) e)
65 where (venv',vdefg') = prepVdefg (venv,tvenv) vdefg
66 prepExp env@(venv,tvenv) (Case e vb t alts) = Case (prepExp env e) vb t (map (prepAlt (eextend venv vb,tvenv)) alts)
67 prepExp env (Cast e t) = Cast (prepExp env e) t
68 prepExp env (Note s e) = Note s (prepExp env e)
69 prepExp _ (External s t) = External s t
71 prepAlt (venv,tvenv) (Acon qdc tbs vbs e) = Acon qdc tbs vbs (prepExp (foldl eextend venv vbs,foldl eextend tvenv tbs) e)
72 prepAlt env (Alit l e) = Alit l (prepExp env e)
73 prepAlt env (Adefault e) = Adefault (prepExp env e)
76 unwindApp env (App e1 e2) as = unwindApp env e1 (Left e2:as)
77 unwindApp env (Appt e t) as = unwindApp env e (Right t:as)
78 unwindApp env (op@(Dcon qdc)) as =
79 etaExpand (drop n atys) (rewindApp env op as)
80 where (tbs,atys0,_) = splitTy (qlookup cenv_ eempty qdc)
81 atys = map (substl (map fst tbs) ts) atys0
82 ts = [t | Right t <- as]
83 n = length [e | Left e <- as]
84 unwindApp env (op@(Var(qv@(_,p)))) as | isPrimVar qv =
85 etaExpand (drop n atys) (rewindApp env op as)
86 where Just atys = elookup primArgTys p
87 n = length [e | Left e <- as]
88 unwindApp env op as = rewindApp env op as
91 etaExpand :: [Ty] -> Exp -> Exp
93 let args = [('$':(show i),t) | (i,t) <- zip [(1::Integer)..] ts] in
94 foldr (\ (v,t) e -> Lam (Vb (v,t)) e)
95 (foldl (\ e (v,_) -> App e (Var (unqual v))) e args)
99 rewindApp env@(venv,tvenv) e1 (Left e2:as) | kindOfTy tvenv t `eqKind` Kunlifted && suspends e2 =
100 -- This is the other place where we call the typechecker.
101 Case newScrut (v,t) (typeOfExp env' rhs) [Adefault rhs]
102 where newScrut = prepExp env e2
103 rhs = (rewindApp env' (App e1 (Var (unqual v))) as)
105 -- e1 gets moved inside rhs. so if we pick a case
106 -- var name (outside e1) equal to a name bound *inside*
107 -- e1, the binding *inside* e1 will shadow "v"
108 -- Which would be name capture!
109 -- So, we pass the bound vars of e1 to freshVar along with
110 -- the domain of the current env.
111 v = freshVar (edomain venv `union` (boundVars e1))
113 env' = (eextend venv (v,t),tvenv)
114 rewindApp env e1 (Left e2:as) = rewindApp env (App e1 (prepExp env e2)) as
115 rewindApp env e (Right t:as) = rewindApp env (Appt e t) as
117 freshVar vs = maximum ("":vs) ++ "x" -- one simple way!
119 typeOfExp :: (Venv, Tvenv) -> Exp -> Ty
120 typeOfExp = uncurry (checkExpr mn globalEnv tdefs)
122 kindOfTy :: Tvenv -> Ty -> Kind
123 kindOfTy tvenv = checkType mn globalEnv tdefs tvenv
125 {- Return false for those expressions for which Interp.suspendExp builds a thunk. -}
126 suspends (Var _) = False
127 suspends (Lit _) = False
128 suspends (Lam (Vb _) _) = False
129 suspends (Lam _ e) = suspends e
130 suspends (Appt e _) = suspends e
131 suspends (Cast e _) = suspends e
132 suspends (Note _ e) = suspends e
133 suspends (External _ _) = False
136 mlookup :: (Envs -> Env a b) -> Env a b -> Mname -> Env a b
137 mlookup _ local_env Nothing = local_env
138 mlookup selector _ (Just m) =
139 case elookup globalEnv m of
140 Just env -> selector env
141 Nothing -> error ("Prep: undefined module name: " ++ show m)
143 qlookup :: (Ord a, Show a) => (Envs -> Env a b) -> Env a b -> (Mname,a) -> b
144 qlookup selector local_env (m,k) =
145 case elookup (mlookup selector local_env m) k of
147 Nothing -> error ("undefined identifier: " ++ show k)
149 boundVars :: Exp -> [Id]
150 boundVars (Lam (Vb (v,_)) e) = [v] `union` boundVars e
151 boundVars (Lam _ e) = boundVars e
152 boundVars (Let vds e) = (boundVarsVdefs vds) `union` boundVars e
153 boundVars (Case scrut (v,_) _ alts) =
154 [v] `union` (boundVars scrut) `union` boundVarsAlts alts
155 boundVars (Cast e _) = boundVars e
156 boundVars (Note _ e) = boundVars e
157 boundVars (App e1 e2) = boundVars e1 `union` boundVars e2
158 boundVars (Appt e _) = boundVars e
161 boundVarsVdefs :: Vdefg -> [Id]
162 boundVarsVdefs (Rec vds) = nub (concatMap boundVarsVdef vds)
163 boundVarsVdefs (Nonrec vd) = boundVarsVdef vd
165 boundVarsVdef :: Vdef -> [Id]
166 boundVarsVdef (Vdef ((_,v),_,e)) = [v] `union` boundVars e
168 boundVarsAlts :: [Alt] -> [Var]
169 boundVarsAlts as = nub (concatMap boundVarsAlt as)
171 boundVarsAlt :: Alt -> [Var]
172 boundVarsAlt (Acon _ _ vbs e) = (map fst vbs) `union` (boundVars e)
173 boundVarsAlt (Alit _ e) = boundVars e
174 boundVarsAlt (Adefault e) = boundVars e