2 Preprocess a module to normalize it in the following ways:
3 (1) Saturate all constructor and primop applications.
4 (2) Arrange that any non-trivial expression of unlifted kind ('#')
5 is turned into the scrutinee of a Case.
6 After these preprocessing steps, Core can be interpreted (or given an operational semantics)
7 ignoring type information almost completely.
19 primArgTys :: Env Var [Ty]
20 primArgTys = efromlist (map f Prims.primVals)
21 where f (v,t) = (v,atys)
22 where (_,atys,_) = splitTy t
24 prepModule :: Menv -> Module -> Module
25 prepModule globalEnv (Module mn tdefs vdefgs) =
26 Module mn tdefs vdefgs'
28 (_,vdefgs') = foldl prepTopVdefg (eempty,[]) vdefgs
30 prepTopVdefg (venv,vdefgs) vdefg = (venv',vdefgs ++ [vdefg'])
31 where (venv',vdefg') = prepVdefg (venv,eempty) vdefg
33 prepVdefg (env@(venv,_)) (Nonrec(Vdef((Nothing,x),t,e))) =
34 (eextend venv (x,t), Nonrec(Vdef((Nothing,x),t,prepExp env e)))
35 prepVdefg (env@(venv,_)) (Nonrec(Vdef(qx,t,e))) =
36 (venv, Nonrec(Vdef(qx,t,prepExp env e)))
37 prepVdefg (venv,tvenv) (Rec vdefs) =
38 (venv',Rec [Vdef(qx,t,prepExp (venv',tvenv) e) | Vdef(qx,t,e) <- vdefs])
39 where venv' = foldl eextend venv [(x,t) | Vdef((Nothing,x),t,_) <- vdefs]
41 prepExp env (Var qv) = Var qv
42 prepExp env (Dcon qdc) = Dcon qdc
43 prepExp env (Lit l) = Lit l
44 prepExp env e@(App _ _) = unwindApp env e []
45 prepExp env e@(Appt _ _) = unwindApp env e []
46 prepExp (venv,tvenv) (Lam (Vb vb) e) = Lam (Vb vb) (prepExp (eextend venv vb,tvenv) e)
47 prepExp (venv,tvenv) (Lam (Tb tb) e) = Lam (Tb tb) (prepExp (venv,eextend tvenv tb) e)
48 prepExp env@(venv,tvenv) (Let (Nonrec(Vdef((Nothing,x),t,b))) e)
49 | kindof tvenv t == Kunlifted && suspends b =
50 -- There are two places where we call the typechecker, one of them
52 -- We need to know the type of the let body in order to construct
54 let eTy = typeOfExp env e in
55 Case (prepExp env b) (x,t)
57 [Adefault (prepExp (eextend venv (x,t),tvenv) e)]
58 prepExp (venv,tvenv) (Let vdefg e) = Let vdefg' (prepExp (venv',tvenv) e)
59 where (venv',vdefg') = prepVdefg (venv,tvenv) vdefg
60 prepExp env@(venv,tvenv) (Case e vb t alts) = Case (prepExp env e) vb t (map (prepAlt (eextend venv vb,tvenv)) alts)
61 prepExp env (Cast e t) = Cast (prepExp env e) t
62 prepExp env (Note s e) = Note s (prepExp env e)
63 prepExp env (External s t) = External s t
65 prepAlt (venv,tvenv) (Acon qdc tbs vbs e) = Acon qdc tbs vbs (prepExp (foldl eextend venv vbs,foldl eextend tvenv tbs) e)
66 prepAlt env (Alit l e) = Alit l (prepExp env e)
67 prepAlt env (Adefault e) = Adefault (prepExp env e)
70 unwindApp env (App e1 e2) as = unwindApp env e1 (Left e2:as)
71 unwindApp env (Appt e t) as = unwindApp env e (Right t:as)
72 unwindApp env (op@(Dcon qdc)) as =
73 etaExpand (drop n atys) (rewindApp env op as)
74 where (tbs,atys0,_) = splitTy (qlookup cenv_ eempty qdc)
75 atys = map (substl (map fst tbs) ts) atys0
76 ts = [t | Right t <- as]
77 n = length [e | Left e <- as]
78 unwindApp env (op@(Var(qv@(_,p)))) as | isPrimVar qv =
79 etaExpand (drop n atys) (rewindApp env op as)
80 where Just atys = elookup primArgTys p
81 n = length [e | Left e <- as]
82 unwindApp env op as = rewindApp env op as
85 etaExpand ts e = foldl g e [('$':(show i),t) | (i,t) <- zip [1..] ts]
86 where g e (v,t) = Lam (Vb(v,t)) (App e (Var (unqual v)))
88 rewindApp env e [] = e
89 rewindApp env@(venv,tvenv) e1 (Left e2:as) | kindof tvenv t == Kunlifted && suspends e2 =
90 -- This is the other place where we call the typechecker.
91 Case (prepExp env' e2) (v,t) (typeOfExp env rhs) [Adefault rhs]
92 where rhs = (rewindApp env' (App e1 (Var (unqual v))) as)
95 env' = (eextend venv (v,t),tvenv)
96 rewindApp env e1 (Left e2:as) = rewindApp env (App e1 (prepExp env e2)) as
97 rewindApp env e (Right t:as) = rewindApp env (Appt e t) as
99 freshVar venv = maximum ("":edomain venv) ++ "x" -- one simple way!
101 typeOfExp :: (Venv, Tvenv) -> Exp -> Ty
102 typeOfExp = uncurry (checkExpr mn globalEnv tdefs)
104 {- Return false for those expressions for which Interp.suspendExp builds a thunk. -}
105 suspends (Var _) = False
106 suspends (Lit _) = False
107 suspends (Lam (Vb _) _) = False
108 suspends (Lam _ e) = suspends e
109 suspends (Appt e _) = suspends e
110 suspends (Cast e _) = suspends e
111 suspends (Note _ e) = suspends e
112 suspends (External _ _) = False
115 kindof :: Tvenv -> Ty -> Kind
116 kindof tvenv (Tvar tv) =
117 case elookup tvenv tv of
119 Nothing -> error ("impossible Tyvar " ++ show tv)
120 kindof tvenv (Tcon qtc) = qlookup tcenv_ eempty qtc
121 kindof tvenv (Tapp t1 t2) = k2
122 where Karrow _ k2 = kindof tvenv t1
123 kindof tvenv (Tforall _ t) = kindof tvenv t
125 mlookup :: (Envs -> Env a b) -> Env a b -> Mname -> Env a b
126 mlookup _ local_env Nothing = local_env
127 mlookup selector _ (Just m) =
128 case elookup globalEnv m of
129 Just env -> selector env
130 Nothing -> error ("Prep: undefined module name: " ++ show m)
132 qlookup :: (Ord a, Show a) => (Envs -> Env a b) -> Env a b -> (Mname,a) -> b
133 qlookup selector local_env (m,k) =
134 case elookup (mlookup selector local_env m) k of
136 Nothing -> error ("undefined identifier: " ++ show k)