X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fext-core%2FPrep.hs;h=df664a5fb8682e4d4dcde8fb967d4280448e32a8;hp=ee65eaaba2831c6a3d63a6bd478f65e0aba7835d;hb=10704b34c1928dde3d0ef33fe37c3eb7b948975f;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/utils/ext-core/Prep.hs b/utils/ext-core/Prep.hs index ee65eaa..df664a5 100644 --- a/utils/ext-core/Prep.hs +++ b/utils/ext-core/Prep.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -Wall -fno-warn-name-shadowing #-} {- Preprocess a module to normalize it in the following ways: (1) Saturate all constructor and primop applications. @@ -10,49 +11,57 @@ After these preprocessing steps, Core can be interpreted (or given an operationa module Prep where +import Data.Either + import Prims import Core -import Printer import Env import Check -primArgTys :: Env Var [Ty] -primArgTys = efromlist (map f Prims.primVals) - where f (v,t) = (v,atys) - where (_,atys,_) = splitTy t +import Data.List prepModule :: Menv -> Module -> Module prepModule globalEnv (Module mn tdefs vdefgs) = Module mn tdefs vdefgs' where + (_,vdefgs') = foldl prepTopVdefg (eempty,[]) vdefgs prepTopVdefg (venv,vdefgs) vdefg = (venv',vdefgs ++ [vdefg']) where (venv',vdefg') = prepVdefg (venv,eempty) vdefg - prepVdefg (env@(venv,_)) (Nonrec(Vdef(("",x),t,e))) = - (eextend venv (x,t), Nonrec(Vdef(("",x),t,prepExp env e))) - prepVdefg (env@(venv,_)) (Nonrec(Vdef(qx,t,e))) = - (venv, Nonrec(Vdef(qx,t,prepExp env e))) + prepVdefg (env@(venv,_)) (Nonrec(Vdef((Nothing,x),t,e))) = + (eextend venv (x,t), Nonrec(Vdef((Nothing,x),t,prepExp env e))) + prepVdefg (env@(venv,_)) (Nonrec(Vdef(qx,t,e))) = + (venv, Nonrec(Vdef(qx,t,prepExp env e))) prepVdefg (venv,tvenv) (Rec vdefs) = - (venv',Rec [Vdef(qx,t,prepExp (venv',tvenv) e) | Vdef(qx,t,e) <- vdefs]) - where venv' = foldl eextend venv [(x,t) | Vdef(("",x),t,_) <- vdefs] + (venv',Rec [ Vdef(qx,t,prepExp (venv',tvenv) e) | Vdef(qx,t,e) <- vdefs]) + where venv' = foldl eextend venv [(x,t) | Vdef((Nothing,x),t,_) <- vdefs] - prepExp env (Var qv) = Var qv - prepExp env (Dcon qdc) = Dcon qdc - prepExp env (Lit l) = Lit l + prepExp _ (Var qv) = Var qv + prepExp _ (Dcon qdc) = Dcon qdc + prepExp _ (Lit l) = Lit l prepExp env e@(App _ _) = unwindApp env e [] prepExp env e@(Appt _ _) = unwindApp env e [] prepExp (venv,tvenv) (Lam (Vb vb) e) = Lam (Vb vb) (prepExp (eextend venv vb,tvenv) e) prepExp (venv,tvenv) (Lam (Tb tb) e) = Lam (Tb tb) (prepExp (venv,eextend tvenv tb) e) - prepExp env@(venv,tvenv) (Let (Nonrec(Vdef(("",x),t,b))) e) | kindof tvenv t == Kunlifted && suspends b = - Case (prepExp env b) (x,t) [Adefault (prepExp (eextend venv (x,t),tvenv) e)] + prepExp env@(venv,tvenv) (Let (Nonrec(Vdef((Nothing,x),t,b))) e) + | (kindOfTy tvenv t `eqKind` Kunlifted && suspends b) = + -- There are two places where we call the typechecker, one of them + -- here. + -- We need to know the type of the let body in order to construct + -- a case expression. + -- need to extend the env with the let-bound var too! + let eTy = typeOfExp (eextend venv (x, t), tvenv) e in + Case (prepExp env b) (x,t) + eTy + [Adefault (prepExp (eextend venv (x,t),tvenv) e)] prepExp (venv,tvenv) (Let vdefg e) = Let vdefg' (prepExp (venv',tvenv) e) where (venv',vdefg') = prepVdefg (venv,tvenv) vdefg - prepExp env@(venv,tvenv) (Case e vb alts) = Case (prepExp env e) vb (map (prepAlt (eextend venv vb,tvenv)) alts) - prepExp env (Coerce t e) = Coerce t (prepExp env e) + prepExp env@(venv,tvenv) (Case e vb t alts) = Case (prepExp env e) vb t (map (prepAlt (eextend venv vb,tvenv)) alts) + prepExp env (Cast e t) = Cast (prepExp env e) t prepExp env (Note s e) = Note s (prepExp env e) - prepExp env (External s t) = External s t + prepExp _ (External s t) = External s t prepAlt (venv,tvenv) (Acon qdc tbs vbs e) = Acon qdc tbs vbs (prepExp (foldl eextend venv vbs,foldl eextend tvenv tbs) e) prepAlt env (Alit l e) = Alit l (prepExp env e) @@ -61,87 +70,84 @@ prepModule globalEnv (Module mn tdefs vdefgs) = unwindApp env (App e1 e2) as = unwindApp env e1 (Left e2:as) unwindApp env (Appt e t) as = unwindApp env e (Right t:as) - unwindApp env (op@(Dcon qdc)) as = - etaExpand (drop n atys) (rewindApp env op as) + unwindApp env (op@(Dcon qdc)) as = + -- possibly dubious to assume no type args + etaExpand [] (drop n atys) (rewindApp env op as) where (tbs,atys0,_) = splitTy (qlookup cenv_ eempty qdc) atys = map (substl (map fst tbs) ts) atys0 ts = [t | Right t <- as] n = length [e | Left e <- as] - unwindApp env (op@(Var(m,p))) as | m == primMname = - etaExpand (drop n atys) (rewindApp env op as) - where Just atys = elookup primArgTys p + unwindApp env (op@(Var(qv@(_,p)))) as | isPrimVar qv = + etaExpand (snd (unzip extraTbs)) (drop n atys) (rewindApp env op as) + where -- TODO: avoid copying code. these two cases are the same + + -- etaExpand needs to add the type arguments too! Bah! + (tbs, atys0, _) = (maybe (error "unwindApp") splitTy (elookup (venv_ primEnv) p)) + n_args = length ts + (appliedTbs, extraTbs) = (take n_args tbs, drop n_args tbs) + atys = map (substl (map fst appliedTbs) ts) atys0 + ts = [t | Right t <- as] n = length [e | Left e <- as] unwindApp env op as = rewindApp env op as - etaExpand ts e = foldl g e [('$':(show i),t) | (i,t) <- zip [1..] ts] - where g e (v,t) = Lam (Vb(v,t)) (App e (Var ("",v))) - - rewindApp env e [] = e - rewindApp env@(venv,tvenv) e1 (Left e2:as) | kindof tvenv t == Kunlifted && suspends e2 = - Case (prepExp env' e2) (v,t) - [Adefault (rewindApp env' (App e1 (Var ("",v))) as)] - where v = freshVar venv - t = typeofExp env e2 + etaExpand :: [Kind] -> [Ty] -> Exp -> Exp + etaExpand ks ts e = + -- what a pain + let tyArgs = [("$t_"++(show i),k) | (i, k) <- zip [(1::Integer)..] ks] + termArgs = [ ('$':(show i),t) | (i,t) <- zip [(1::Integer)..] ts] in + foldr (\ (t1,k1) e -> Lam (Tb (t1,k1)) e) + (foldr (\ (v,t) e -> Lam (Vb (v,t)) e) + (foldl (\ e (v,_) -> App e (Var (unqual v))) + (foldl (\ e (tv,_) -> Appt e (Tvar tv)) + e tyArgs) + termArgs) termArgs) + tyArgs + + rewindApp _ e [] = e + rewindApp env@(venv,tvenv) e1 (Left e2:as) | kindOfTy tvenv t `eqKind` Kunlifted && suspends e2 = + -- This is the other place where we call the typechecker. + Case newScrut (v,t) (typeOfExp env' rhs) [Adefault rhs] + where newScrut = prepExp env e2 + rhs = (rewindApp env' (App e1 (Var (unqual v))) as) + -- note: + -- e1 gets moved inside rhs. so if we pick a case + -- var name (outside e1) equal to a name bound *inside* + -- e1, the binding *inside* e1 will shadow "v" + -- Which would be name capture! + -- So, we pass the bound vars of e1 to freshVar along with + -- the domain of the current env. + v = freshVar (edomain venv `union` (boundVars e1)) + t = typeOfExp env e2 env' = (eextend venv (v,t),tvenv) rewindApp env e1 (Left e2:as) = rewindApp env (App e1 (prepExp env e2)) as rewindApp env e (Right t:as) = rewindApp env (Appt e t) as - freshVar venv = maximum ("":edomain venv) ++ "x" -- one simple way! - - typeofExp :: (Venv,Tvenv) -> Exp -> Ty - typeofExp (venv,_) (Var qv) = qlookup venv_ venv qv - typeofExp env (Dcon qdc) = qlookup cenv_ eempty qdc - typeofExp env (Lit l) = typeofLit l - where typeofLit (Lint _ t) = t - typeofLit (Lrational _ t) = t - typeofLit (Lchar _ t) = t - typeofLit (Lstring _ t) = t - typeofExp env (App e1 e2) = t - where (Tapp(Tapp _ t0) t) = typeofExp env e1 - typeofExp env (Appt e t) = substl [tv] [t] t' - where (Tforall (tv,_) t') = typeofExp env e - typeofExp (venv,tvenv) (Lam (Vb(v,t)) e) = tArrow t (typeofExp (eextend venv (v,t),tvenv) e) - typeofExp (venv,tvenv) (Lam (Tb tb) e) = Tforall tb (typeofExp (venv,eextend tvenv tb) e) - typeofExp (venv,tvenv) (Let vdefg e) = typeofExp (venv',tvenv) e - where venv' = case vdefg of - Nonrec (Vdef((_,x),t,_)) -> eextend venv (x,t) - Rec vdefs -> foldl eextend venv [(x,t) | Vdef((_,x),t,_) <- vdefs] - typeofExp (venv,tvenv) (Case _ vb (alt:_)) = typeofAlt (eextend venv vb,tvenv) alt - where typeofAlt (venv,tvenv) (Acon _ tbs vbs e) = typeofExp (foldl eextend venv vbs,foldl eextend tvenv tbs) e - typeofAlt env (Alit _ e) = typeofExp env e - typeofAlt env (Adefault e) = typeofExp env e - typeofExp env (Coerce t _) = t - typeofExp env (Note _ e) = typeofExp env e - typeofExp env (External _ t) = t - - {- Return false for those expressions for which Interp.suspendExp buidds a thunk. -} + freshVar vs = maximum ("":vs) ++ "x" -- one simple way! + + typeOfExp :: (Venv, Tvenv) -> Exp -> Ty + typeOfExp = uncurry (checkExpr mn globalEnv tdefs) + + kindOfTy :: Tvenv -> Ty -> Kind + kindOfTy tvenv = checkType mn globalEnv tdefs tvenv + + {- Return false for those expressions for which Interp.suspendExp builds a thunk. -} suspends (Var _) = False suspends (Lit _) = False suspends (Lam (Vb _) _) = False suspends (Lam _ e) = suspends e suspends (Appt e _) = suspends e - suspends (Coerce _ e) = suspends e + suspends (Cast e _) = suspends e suspends (Note _ e) = suspends e suspends (External _ _) = False suspends _ = True - kindof :: Tvenv -> Ty -> Kind - kindof tvenv (Tvar tv) = - case elookup tvenv tv of - Just k -> k - Nothing -> error ("impossible Tyvar " ++ show tv) - kindof tvenv (Tcon qtc) = qlookup tcenv_ eempty qtc - kindof tvenv (Tapp t1 t2) = k2 - where Karrow _ k2 = kindof tvenv t1 - kindof tvenv (Tforall _ t) = kindof tvenv t - mlookup :: (Envs -> Env a b) -> Env a b -> Mname -> Env a b - mlookup _ local_env "" = local_env - mlookup selector _ m = + mlookup _ local_env Nothing = local_env + mlookup selector _ (Just m) = case elookup globalEnv m of Just env -> selector env - Nothing -> error ("undefined module name: " ++ m) + Nothing -> error ("Prep: undefined module name: " ++ show m) qlookup :: (Ord a, Show a) => (Envs -> Env a b) -> Env a b -> (Mname,a) -> b qlookup selector local_env (m,k) = @@ -149,3 +155,29 @@ prepModule globalEnv (Module mn tdefs vdefgs) = Just v -> v Nothing -> error ("undefined identifier: " ++ show k) +boundVars :: Exp -> [Id] +boundVars (Lam (Vb (v,_)) e) = [v] `union` boundVars e +boundVars (Lam _ e) = boundVars e +boundVars (Let vds e) = (boundVarsVdefs vds) `union` boundVars e +boundVars (Case scrut (v,_) _ alts) = + [v] `union` (boundVars scrut) `union` boundVarsAlts alts +boundVars (Cast e _) = boundVars e +boundVars (Note _ e) = boundVars e +boundVars (App e1 e2) = boundVars e1 `union` boundVars e2 +boundVars (Appt e _) = boundVars e +boundVars _ = [] + +boundVarsVdefs :: Vdefg -> [Id] +boundVarsVdefs (Rec vds) = nub (concatMap boundVarsVdef vds) +boundVarsVdefs (Nonrec vd) = boundVarsVdef vd + +boundVarsVdef :: Vdef -> [Id] +boundVarsVdef (Vdef ((_,v),_,e)) = [v] `union` boundVars e + +boundVarsAlts :: [Alt] -> [Var] +boundVarsAlts as = nub (concatMap boundVarsAlt as) + +boundVarsAlt :: Alt -> [Var] +boundVarsAlt (Acon _ _ vbs e) = (map fst vbs) `union` (boundVars e) +boundVarsAlt (Alit _ e) = boundVars e +boundVarsAlt (Adefault e) = boundVars e \ No newline at end of file