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