utils/ext-core/Prep.hs

   1 {-
   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.
   8 -}
   9
  10
  11 module Prep where
  12
  13 import Prims
  14 import Core
  15 import Printer
  16 import Env
  17 import Check
  18
  19 primArgTys :: Env Var [Ty]
  20 primArgTys = efromlist (map f Prims.primVals)
  21   where f (v,t) = (v,atys)
  22              where (_,atys,_) = splitTy t
  23
  24 prepModule :: Menv -> Module -> Module
  25 prepModule globalEnv (Module mn tdefs vdefgs) =
  26     Module mn tdefs vdefgs'
  27   where
  28     (_,vdefgs') = foldl prepTopVdefg (eempty,[]) vdefgs
  29
  30     prepTopVdefg (venv,vdefgs) vdefg = (venv',vdefgs ++ [vdefg'])
  31        where (venv',vdefg') = prepVdefg (venv,eempty) vdefg
  32
  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]
  40
  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 `eqKind` Kunlifted && suspends b =
  50             -- There are two places where we call the typechecker, one of them
  51             -- here.
  52             -- We need to know the type of the let body in order to construct
  53             -- a case expression.
  54             let eTy = typeOfExp env e in
  55                 Case (prepExp env b) (x,t)
  56                   eTy
  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
  64
  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)
  68
  69
  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
  83
  84
  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)))
  87
  88     rewindApp env e [] = e
  89     rewindApp env@(venv,tvenv) e1 (Left e2:as) | kindof tvenv t `eqKind` 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)
  93               v = freshVar venv
  94               t = typeOfExp env e2
  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
  98
  99     freshVar venv = maximum ("":edomain venv) ++ "x" -- one simple way!
 100
 101     typeOfExp :: (Venv, Tvenv) -> Exp -> Ty
 102     typeOfExp = uncurry (checkExpr mn globalEnv tdefs)
 103
 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
 113     suspends _ = True
 114
 115     kindof :: Tvenv -> Ty -> Kind
 116     kindof tvenv (Tvar tv) =
 117       case elookup tvenv tv of
 118         Just k -> k
 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
 124
 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)
 131
 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
 135         Just v -> v
 136         Nothing -> error ("undefined identifier: " ++ show k)
 137