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(("",x),t,e))) =
  34         (eextend venv (x,t), Nonrec(Vdef(("",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(("",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(("",x),t,b))) e) | kindof tvenv t == Kunlifted && suspends b =
  49                 Case (prepExp env b) (x,t) [Adefault (prepExp (eextend venv (x,t),tvenv) e)]
  50     prepExp (venv,tvenv) (Let vdefg e) =  Let vdefg' (prepExp (venv',tvenv) e)
  51                 where (venv',vdefg') = prepVdefg (venv,tvenv) vdefg
  52     prepExp env@(venv,tvenv) (Case e vb alts) = Case (prepExp env e) vb (map (prepAlt (eextend venv vb,tvenv)) alts)
  53     prepExp env (Coerce t e) = Coerce t (prepExp env e)
  54     prepExp env (Note s e) = Note s (prepExp env e)
  55     prepExp env (External s t) = External s t
  56
  57     prepAlt (venv,tvenv) (Acon qdc tbs vbs e) = Acon qdc tbs vbs (prepExp (foldl eextend venv vbs,foldl eextend tvenv tbs) e)
  58     prepAlt env (Alit l e) = Alit l (prepExp env e)
  59     prepAlt env (Adefault e) = Adefault (prepExp env e)
  60
  61
  62     unwindApp env (App e1 e2) as = unwindApp env e1 (Left e2:as)
  63     unwindApp env (Appt e t) as  = unwindApp env e (Right t:as)
  64     unwindApp env (op@(Dcon qdc)) as =
  65         etaExpand (drop n atys) (rewindApp env op as)
  66         where (tbs,atys0,_) = splitTy (qlookup cenv_ eempty qdc)
  67               atys = map (substl (map fst tbs) ts) atys0
  68               ts = [t | Right t <- as]
  69               n = length [e | Left e <- as]
  70     unwindApp env (op@(Var(m,p))) as | m == primMname =
  71         etaExpand (drop n atys) (rewindApp env op as)
  72         where Just atys = elookup primArgTys p
  73               n = length [e | Left e <- as]
  74     unwindApp env op as = rewindApp env op as
  75
  76
  77     etaExpand ts e = foldl g e [('$':(show i),t) | (i,t) <- zip [1..] ts]
  78           where g e (v,t) = Lam (Vb(v,t)) (App e (Var ("",v)))
  79
  80     rewindApp env e [] = e
  81     rewindApp env@(venv,tvenv) e1 (Left e2:as) | kindof tvenv t == Kunlifted && suspends e2 =
  82         Case (prepExp env' e2) (v,t)
  83                 [Adefault (rewindApp env' (App e1 (Var ("",v))) as)]
  84         where v = freshVar venv
  85               t = typeofExp env e2
  86               env' = (eextend venv (v,t),tvenv)
  87     rewindApp env e1 (Left e2:as) = rewindApp env (App e1 (prepExp env e2)) as
  88     rewindApp env e (Right t:as) = rewindApp env (Appt e t) as
  89
  90     freshVar venv = maximum ("":edomain venv) ++ "x" -- one simple way!
  91
  92     typeofExp :: (Venv,Tvenv) -> Exp -> Ty
  93     typeofExp (venv,_) (Var qv) = qlookup venv_ venv qv
  94     typeofExp env (Dcon qdc) = qlookup cenv_ eempty qdc
  95     typeofExp env (Lit l) = typeofLit l
  96         where typeofLit (Lint _ t) = t
  97               typeofLit (Lrational _ t) = t
  98               typeofLit (Lchar _ t) = t
  99               typeofLit (Lstring _ t) = t
 100     typeofExp env (App e1 e2) = t
 101           where (Tapp(Tapp _ t0) t) = typeofExp env e1
 102     typeofExp env (Appt e t) = substl [tv] [t] t'
 103           where (Tforall (tv,_) t') = typeofExp env e
 104     typeofExp (venv,tvenv) (Lam (Vb(v,t)) e) = tArrow t (typeofExp (eextend venv (v,t),tvenv) e)
 105     typeofExp (venv,tvenv) (Lam (Tb tb) e) = Tforall tb (typeofExp (venv,eextend tvenv tb) e)
 106     typeofExp (venv,tvenv) (Let vdefg e) = typeofExp (venv',tvenv) e
 107           where venv' = case vdefg of
 108                           Nonrec (Vdef((_,x),t,_)) -> eextend venv (x,t)
 109                           Rec vdefs -> foldl eextend venv [(x,t) | Vdef((_,x),t,_) <- vdefs]
 110     typeofExp (venv,tvenv) (Case _ vb (alt:_)) = typeofAlt (eextend venv vb,tvenv) alt
 111         where typeofAlt (venv,tvenv) (Acon _ tbs vbs e) = typeofExp (foldl eextend venv vbs,foldl eextend tvenv tbs) e
 112               typeofAlt env (Alit _ e) = typeofExp env e
 113               typeofAlt env (Adefault e) = typeofExp env e
 114     typeofExp env (Coerce t _) = t
 115     typeofExp env (Note _ e) = typeofExp env e
 116     typeofExp env (External _ t) = t
 117
 118     {- Return false for those expressions for which Interp.suspendExp buidds a thunk. -}
 119     suspends (Var _) = False
 120     suspends (Lit _) = False
 121     suspends (Lam (Vb _) _) = False
 122     suspends (Lam _ e) = suspends e
 123     suspends (Appt e _) = suspends e
 124     suspends (Coerce _ e) = suspends e
 125     suspends (Note _ e) = suspends e
 126     suspends (External _ _) = False
 127     suspends _ = True
 128
 129     kindof :: Tvenv -> Ty -> Kind
 130     kindof tvenv (Tvar tv) =
 131       case elookup tvenv tv of
 132         Just k -> k
 133         Nothing -> error ("impossible Tyvar " ++ show tv)
 134     kindof tvenv (Tcon qtc) = qlookup tcenv_ eempty qtc
 135     kindof tvenv (Tapp t1 t2) = k2
 136         where Karrow _ k2 = kindof tvenv t1
 137     kindof tvenv (Tforall _ t) = kindof tvenv t
 138
 139     mlookup :: (Envs -> Env a b) -> Env a b -> Mname -> Env a b
 140     mlookup _ local_env "" = local_env
 141     mlookup selector _  m =
 142       case elookup globalEnv m of
 143         Just env -> selector env
 144         Nothing -> error ("undefined module name: " ++ m)
 145
 146     qlookup ::  (Ord a, Show a) => (Envs -> Env a b) -> Env a b -> (Mname,a) -> b
 147     qlookup selector local_env (m,k) =
 148       case elookup (mlookup selector local_env m) k of
 149         Just v -> v
 150         Nothing -> error ("undefined identifier: " ++ show k)
 151