utils/ext-core/Language/Core/Prep.hs

   1 {-# OPTIONS -Wall -fno-warn-name-shadowing #-}
   2 {-
   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.
   9 -}
  10
  11
  12 module Language.Core.Prep where
  13
  14 import Data.Either
  15 import Data.List
  16
  17 import Language.Core.Prims
  18 import Language.Core.Core
  19 import Language.Core.Env
  20 import Language.Core.Check
  21
  22 prepModule :: Menv -> Module -> Module
  23 prepModule globalEnv (Module mn tdefs vdefgs) =
  24     Module mn tdefs vdefgs'
  25   where
  26
  27     (_,vdefgs') = foldl prepTopVdefg (eempty,[]) vdefgs
  28
  29     prepTopVdefg (venv,vdefgs) vdefg = (venv',vdefgs ++ [vdefg'])
  30        where (venv',vdefg') = prepVdefg (venv,eempty) vdefg
  31
  32     prepVdefg (env@(venv,_)) (Nonrec(Vdef((Nothing,x),t,e))) =
  33         (eextend venv (x,t), Nonrec(Vdef((Nothing,x),t,prepExp env e)))
  34     prepVdefg (env@(venv,_))  (Nonrec(Vdef(qx,t,e))) =
  35         (venv, Nonrec(Vdef(qx,t,prepExp env e)))
  36     prepVdefg (venv,tvenv) (Rec vdefs) =
  37         (venv',Rec [ Vdef(qx,t,prepExp (venv',tvenv) e) | Vdef(qx,t,e) <- vdefs])
  38         where venv' = foldl eextend venv [(x,t) | Vdef((Nothing,x),t,_) <- vdefs]
  39
  40     prepExp _ (Var qv) = Var qv
  41     prepExp _ (Dcon qdc) = Dcon qdc
  42     prepExp _ (Lit l) = Lit l
  43     prepExp env e@(App _ _) = unwindApp env e []
  44     prepExp env e@(Appt _ _) = unwindApp env e []
  45     prepExp (venv,tvenv) (Lam (Vb vb) e) = Lam (Vb vb) (prepExp (eextend venv vb,tvenv) e)
  46     prepExp (venv,tvenv) (Lam (Tb tb) e) = Lam (Tb tb) (prepExp (venv,eextend tvenv tb) e)
  47     prepExp env@(venv,tvenv) (Let (Nonrec(Vdef((Nothing,x),t,b))) e)
  48         | (kindOfTy tvenv t `eqKind` Kunlifted && suspends b) =
  49             -- There are two places where we call the typechecker, one of them
  50             -- here.
  51             -- We need to know the type of the let body in order to construct
  52             -- a case expression.
  53                                 -- need to extend the env with the let-bound var too!
  54             let eTy = typeOfExp (eextend venv (x, t), tvenv) 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 _ (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         -- possibly dubious to assume no type args
  74         etaExpand [] (drop n atys) (rewindApp env op as)
  75         where (tbs,atys0,_) = splitTy (qlookup cenv_ eempty qdc)
  76               atys = map (substl (map fst tbs) ts) atys0
  77               ts = [t | Right t <- as]
  78               n = length [e | Left e <- as]
  79     unwindApp env (op@(Var(qv@(_,p)))) as | isPrimVar qv =
  80         etaExpand (snd (unzip extraTbs)) (drop n atys) (rewindApp env op as)
  81         where -- TODO: avoid copying code. these two cases are the same
  82
  83               -- etaExpand needs to add the type arguments too! Bah!
  84               (tbs, atys0, _) = (maybe (error "unwindApp") splitTy (elookup (venv_ primEnv) p))
  85               n_args = length ts
  86               (appliedTbs, extraTbs) = (take n_args tbs, drop n_args tbs)
  87               atys = map (substl (map fst appliedTbs) ts) atys0
  88               ts = [t | Right t <- as]
  89               n = length [e | Left e <- as]
  90     unwindApp env op as = rewindApp env op as
  91
  92
  93     etaExpand :: [Kind] -> [Ty] -> Exp -> Exp
  94     etaExpand ks ts e =
  95          -- what a pain
  96          let tyArgs = [("$t_"++(show i),k) | (i, k) <- zip [(1::Integer)..] ks]
  97              termArgs = [ ('$':(show i),t) | (i,t) <- zip [(1::Integer)..] ts] in
  98           foldr (\ (t1,k1) e -> Lam (Tb (t1,k1)) e)
  99            (foldr (\ (v,t) e -> Lam (Vb (v,t)) e)
 100               (foldl (\ e (v,_) -> App e (Var (unqual v)))
 101                  (foldl (\ e (tv,_) -> Appt e (Tvar tv))
 102                    e tyArgs)
 103               termArgs) termArgs)
 104            tyArgs
 105
 106     rewindApp _ e [] = e
 107     rewindApp env@(venv,tvenv) e1 (Left e2:as) | kindOfTy tvenv t `eqKind` Kunlifted && suspends e2 =
 108        -- This is the other place where we call the typechecker.
 109         Case newScrut (v,t) (typeOfExp env' rhs) [Adefault rhs]
 110         where newScrut = prepExp env e2
 111               rhs = (rewindApp env' (App e1 (Var (unqual v))) as)
 112                  -- note:
 113                  -- e1 gets moved inside rhs. so if we pick a case
 114                  -- var name (outside e1) equal to a name bound *inside*
 115                  -- e1, the binding *inside* e1 will shadow "v"
 116                  -- Which would be name capture!
 117                  -- So, we pass the bound vars of e1 to freshVar along with
 118                  -- the domain of the current env.
 119               v = freshVar (edomain venv `union` (boundVars e1))
 120               t = typeOfExp env e2
 121               env' = (eextend venv (v,t),tvenv)
 122     rewindApp env e1 (Left e2:as) = rewindApp env (App e1 (prepExp env e2)) as
 123     rewindApp env e (Right t:as) = rewindApp env (Appt e t) as
 124
 125     freshVar vs = maximum ("":vs) ++ "x" -- one simple way!
 126
 127     typeOfExp :: (Venv, Tvenv) -> Exp -> Ty
 128     typeOfExp = uncurry (checkExpr mn globalEnv tdefs)
 129
 130     kindOfTy :: Tvenv -> Ty -> Kind
 131     kindOfTy tvenv = checkType mn globalEnv tdefs tvenv
 132
 133     {- Return false for those expressions for which Interp.suspendExp builds a thunk. -}
 134     suspends (Var _) = False
 135     suspends (Lit _) = False
 136     suspends (Lam (Vb _) _) = False
 137     suspends (Lam _ e) = suspends e
 138     suspends (Appt e _) = suspends e
 139     suspends (Cast e _) = suspends e
 140     suspends (Note _ e) = suspends e
 141     suspends (External _ _) = False
 142     suspends _ = True
 143
 144     mlookup :: (Envs -> Env a b) -> Env a b -> Mname -> Env a b
 145     mlookup _ local_env Nothing = local_env
 146     mlookup selector _  (Just m) =
 147       case elookup globalEnv m of
 148         Just env -> selector env
 149         Nothing -> error ("Prep: undefined module name: " ++ show m)
 150
 151     qlookup ::  (Ord a, Show a) => (Envs -> Env a b) -> Env a b -> (Mname,a) -> b
 152     qlookup selector local_env (m,k) =
 153       case elookup (mlookup selector local_env m) k of
 154         Just v -> v
 155         Nothing -> error ("undefined identifier: " ++ show k)
 156
 157 boundVars :: Exp -> [Id]
 158 boundVars (Lam (Vb (v,_)) e) = [v] `union` boundVars e
 159 boundVars (Lam _ e) = boundVars e
 160 boundVars (Let vds e) = (boundVarsVdefs vds) `union` boundVars e
 161 boundVars (Case scrut (v,_) _ alts) =
 162    [v] `union` (boundVars scrut) `union` boundVarsAlts alts
 163 boundVars (Cast e _) = boundVars e
 164 boundVars (Note _ e) = boundVars e
 165 boundVars (App e1 e2) = boundVars e1 `union` boundVars e2
 166 boundVars (Appt e _) = boundVars e
 167 boundVars _ = []
 168
 169 boundVarsVdefs :: Vdefg -> [Id]
 170 boundVarsVdefs (Rec vds) = nub (concatMap boundVarsVdef vds)
 171 boundVarsVdefs (Nonrec vd) = boundVarsVdef vd
 172
 173 boundVarsVdef :: Vdef -> [Id]
 174 boundVarsVdef (Vdef ((_,v),_,e)) = [v] `union` boundVars e
 175
 176 boundVarsAlts :: [Alt] -> [Var]
 177 boundVarsAlts as = nub (concatMap boundVarsAlt as)
 178
 179 boundVarsAlt :: Alt -> [Var]
 180 boundVarsAlt (Acon _ _ vbs e) = (map fst vbs) `union` (boundVars e)
 181 boundVarsAlt (Alit _ e) = boundVars e
 182 boundVarsAlt (Adefault e) = boundVars e