From 5a4c6ef6e909fbd978ff81bb3453489e884d1885 Mon Sep 17 00:00:00 2001 From: Tim Chevalier Date: Wed, 14 Jan 2009 22:44:28 +0000 Subject: [PATCH] External Core lib: lots of cleanup - Factor out code for applying newtypes from Check into CoreUtils - Use this code in Prep, which allowed for some simplification - Change Merge and ElimDeadCode to not flatten top-level binds - Add a flag for elimDeadCode to tell it whether to keep exported bindings or not. - Other things. --- utils/ext-core/Language/Core/Check.hs | 152 +++++++++++--------------- utils/ext-core/Language/Core/CoreUtils.hs | 121 +++++++++++++++++++- utils/ext-core/Language/Core/ElimDeadCode.hs | 23 ++-- utils/ext-core/Language/Core/Merge.hs | 14 ++- utils/ext-core/Language/Core/Prep.hs | 70 ++---------- utils/ext-core/Language/Core/Printer.hs | 5 + utils/ext-core/Language/Core/Utils.hs | 2 +- utils/ext-core/extcore.cabal | 4 +- 8 files changed, 225 insertions(+), 166 deletions(-) diff --git a/utils/ext-core/Language/Core/Check.hs b/utils/ext-core/Language/Core/Check.hs index 2331ea0..9f7a276 100644 --- a/utils/ext-core/Language/Core/Check.hs +++ b/utils/ext-core/Language/Core/Check.hs @@ -7,7 +7,10 @@ module Language.Core.Check( CheckRes(..), splitTy, substl, mkTypeEnvsNoChecking) where +--import Debug.Trace + import Language.Core.Core +import Language.Core.CoreUtils import Language.Core.Printer() import Language.Core.PrimEnv import Language.Core.Env @@ -43,25 +46,22 @@ require False s = fail s require True _ = return () -extendM :: (Ord a, Show a) => EnvType -> Env a b -> (a,b) -> CheckResult (Env a b) -extendM envType env (k,d) = +extendM :: (Ord a, Show a) => Bool -> EnvType -> Env a b -> (a,b) -> CheckResult (Env a b) +extendM checkNameShadowing envType env (k,d) = case elookup env k of - Just _ | envType == NotTv -> fail ("multiply-defined identifier: " + Just _ | envType == NotTv && checkNameShadowing -> fail ("multiply-defined identifier: " ++ show k) _ -> return (eextend env (k,d)) -extendVenv :: (Ord a, Show a) => Env a b -> (a,b) -> CheckResult (Env a b) -extendVenv = extendM NotTv +extendVenv :: (Ord a, Show a) => Bool -> Env a b -> (a,b) -> CheckResult (Env a b) +extendVenv check = extendM check NotTv extendTvenv :: (Ord a, Show a) => Env a b -> (a,b) -> CheckResult (Env a b) -extendTvenv = extendM Tv +extendTvenv = extendM True Tv -lookupM :: (Ord a, Show a) => Env a b -> a -> CheckResult b -lookupM env k = - case elookup env k of - Just v -> return v - Nothing -> fail ("undefined identifier: " ++ show k ++ " e = " ++ show (edomain env)) - +lookupM :: (Ord a, Show a) => Env a b -> a -> CheckResult (Maybe b) +lookupM env k = return $ elookup env k + {- Main entry point. -} checkModule :: Menv -> Module -> CheckRes Menv checkModule globalEnv (Module mn tdefs vdefgs) = @@ -72,8 +72,7 @@ checkModule globalEnv (Module mn tdefs vdefgs) = vdefgs return (eextend globalEnv (mn,Envs{tcenv_=tcenv,cenv_=cenv,venv_=e_venv}))) - -- avoid name shadowing - (mn, eremove globalEnv mn) + (mn, globalEnv) -- Like checkModule, but doesn't typecheck the code, instead just -- returning declared types for top-level defns. @@ -93,8 +92,7 @@ envsModule globalEnv (Module mn tdefs vdefgs) = add :: [(Qual Var,Ty)] -> Venv -> Venv add pairs e = foldr addOne e pairs addOne :: (Qual Var, Ty) -> Venv -> Venv - addOne ((Nothing,_),_) e = e - addOne ((Just _,v),t) e = eextend e (v,t) + addOne ((_,v),t) e = eextend e (v,t) checkTdef0 :: Tcenv -> Tdef -> CheckResult Tcenv checkTdef0 tcenv tdef = ch tdef @@ -102,12 +100,12 @@ checkTdef0 tcenv tdef = ch tdef ch (Data (m,c) tbs _) = do mn <- getMname requireModulesEq m mn "data type declaration" tdef False - extendM NotTv tcenv (c, Kind k) + extendM True NotTv tcenv (c, Kind k) where k = foldr Karrow Klifted (map snd tbs) ch (Newtype (m,c) coVar tbs rhs) = do mn <- getMname requireModulesEq m mn "newtype declaration" tdef False - tcenv' <- extendM NotTv tcenv (c, Kind k) + tcenv' <- extendM True NotTv tcenv (c, Kind k) -- add newtype axiom to env tcenv'' <- envPlusNewtype tcenv' (m,c) coVar tbs rhs return tcenv'' @@ -128,7 +126,7 @@ processTdef0NoChecking tcenv tdef = ch tdef envPlusNewtype :: Tcenv -> Qual Tcon -> Qual Tcon -> [Tbind] -> Ty -> CheckResult Tcenv -envPlusNewtype tcenv tyCon coVar tbs rep = extendM NotTv tcenv +envPlusNewtype tcenv tyCon coVar tbs rep = extendM True NotTv tcenv (snd coVar, Coercion $ DefinedCoercion tbs (foldl Tapp (Tcon tyCon) (map Tvar (fst (unzip tbs))), @@ -139,12 +137,12 @@ checkTdef tcenv cenv = ch where ch (Data (_,c) utbs cdefs) = do cbinds <- mapM checkCdef cdefs - foldM (extendM NotTv) cenv cbinds + foldM (extendM True NotTv) cenv cbinds where checkCdef (cdef@(Constr (m,dcon) etbs ts)) = do mn <- getMname requireModulesEq m mn "constructor declaration" cdef False - tvenv <- foldM (extendM Tv) eempty tbs + tvenv <- foldM (extendM True Tv) eempty tbs ks <- mapM (checkTy (tcenv,tvenv)) ts mapM_ (\k -> require (baseKind k) ("higher-order kind in:\n" ++ show cdef ++ "\n" ++ @@ -156,7 +154,7 @@ checkTdef tcenv cenv = ch (foldl Tapp (Tcon (Just mn,c)) (map (Tvar . fst) utbs)) ts) tbs ch (tdef@(Newtype tc _ tbs t)) = - do tvenv <- foldM (extendM Tv) eempty tbs + do tvenv <- foldM (extendM True Tv) eempty tbs kRhs <- checkTy (tcenv,tvenv) t require (kRhs `eqKind` Klifted) ("bad kind:\n" ++ show tdef) kLhs <- checkTy (tcenv,tvenv) @@ -209,7 +207,7 @@ checkVdefg top_level (tcenv,tvenv,cenv) (e_venv,l_venv) vdefg = do case vdefg of Rec vdefs -> do (e_venv', l_venv') <- makeEnv mn vdefs - let env' = (tcenv,tvenv,cenv,e_venv',l_venv') + let env' = (tcenv,tvenv,cenv,e_venv',l_venv') mapM_ (checkVdef (\ vdef k -> require (k `eqKind` Klifted) ("unlifted kind in:\n" ++ show vdef)) env') vdefs @@ -223,8 +221,8 @@ checkVdefg top_level (tcenv,tvenv,cenv) (e_venv,l_venv) vdefg = do makeEnv mn [vdef] where makeEnv mn vdefs = do - ev <- foldM extendVenv e_venv e_vts - lv <- foldM extendVenv l_venv l_vts + ev <- foldM (extendVenv False) e_venv e_vts + lv <- foldM (extendVenv False) l_venv l_vts return (ev, lv) where e_vts = [ (v,t) | Vdef ((Just m,v),t,_) <- vdefs, not (vdefIsMainWrapper mn (Just m))] @@ -311,7 +309,7 @@ checkExp (tcenv,tvenv,cenv,e_venv,l_venv) = ch require (baseKind k) ("higher-order kind in:\n" ++ show e0 ++ "\n" ++ "kind: " ++ show k) - l_venv' <- extendVenv l_venv vb + l_venv' <- extendVenv True l_venv vb t <- checkExp (tcenv,tvenv,cenv,e_venv,l_venv') e require (not (isUtupleTy vt)) ("lambda-bound unboxed tuple in:\n" ++ show e0) return (tArrow vt t) @@ -347,7 +345,7 @@ checkExp (tcenv,tvenv,cenv,e_venv,l_venv) = ch in ok as [l] [Adefault _] -> return () _ -> fail ("no alternatives in case:\n" ++ show e0) - l_venv' <- extendVenv l_venv (v,t) + l_venv' <- extendVenv True l_venv (v,t) t:ts <- mapM (checkAlt (tcenv,tvenv,cenv,e_venv,l_venv') t) alts require (all (== t) ts) ("alternative types don't match in:\n" ++ show e0 ++ "\n" ++ @@ -413,7 +411,7 @@ checkAlt (env@(tcenv,tvenv,cenv,e_venv,l_venv)) t0 = ch ("pattern constructor type doesn't match scrutinee type in:\n" ++ show a0 ++ "\n" ++ "pattern constructor type: " ++ show ct_res ++ "\n" ++ "scrutinee type: " ++ show t0) - l_venv' <- foldM extendVenv l_venv vbs + l_venv' <- foldM (extendVenv True) l_venv vbs t <- checkExp (tcenv,tvenv',cenv,e_venv,l_venv') e checkTy (tcenv,tvenv) t {- check that existentials don't escape in result type -} return t @@ -430,7 +428,11 @@ checkAlt (env@(tcenv,tvenv,cenv,e_venv,l_venv)) t0 = ch checkTy :: (Tcenv,Tvenv) -> Ty -> CheckResult Kind checkTy es@(tcenv,tvenv) = ch where - ch (Tvar tv) = lookupM tvenv tv + ch (Tvar tv) = do + res <- lookupM tvenv tv + case res of + Just k -> return k + Nothing -> fail ("Undefined tvar: " ++ show tv) ch (Tcon qtc) = do kOrC <- qlookupM tcenv_ tcenv eempty qtc case kOrC of @@ -443,11 +445,11 @@ checkTy es@(tcenv,tvenv) = ch tcK <- qlookupM tcenv_ tcenv eempty tc case tcK of Kind _ -> checkTapp t1 t2 - Coercion (DefinedCoercion tbs (from,to)) -> do + Coercion co@(DefinedCoercion tbs _) -> do -- makes sure coercion is fully applied require (length tys == length tbs) $ ("Arity mismatch in coercion app: " ++ show t) - let (tvs, tks) = unzip tbs + let (_, tks) = unzip tbs argKs <- mapM (checkTy es) tys let kPairs = zip argKs tks -- Simon says it's okay for these to be @@ -456,7 +458,7 @@ checkTy es@(tcenv,tvenv) = ch require kindsOk ("Kind mismatch in coercion app: " ++ show tks ++ " and " ++ show argKs ++ " t = " ++ show t) - return $ Keq (substl tvs tys from) (substl tvs tys to) + return $ (uncurry Keq) (applyNewtype co tys) Nothing -> checkTapp t1 t2 where checkTapp t1 t2 = do k1 <- ch t1 @@ -521,17 +523,17 @@ checkTyCo es@(tcenv,_) t@(Tapp t1 t2) = -- todo: avoid duplicating this code -- blah, this almost calls for a different syntactic form -- (for a defined-coercion app): (TCoercionApp Tcon [Ty]) - Coercion (DefinedCoercion tbs (from, to)) -> do + Coercion co@(DefinedCoercion tbs _) -> do require (length tys == length tbs) $ ("Arity mismatch in coercion app: " ++ show t) - let (tvs, tks) = unzip tbs + let (_, tks) = unzip tbs argKs <- mapM (checkTy es) tys let kPairs = zip argKs tks let kindsOk = all (uncurry subKindOf) kPairs require kindsOk ("Kind mismatch in coercion app: " ++ show tks ++ " and " ++ show argKs ++ " t = " ++ show t) - return (substl tvs tys from, substl tvs tys to) + return (applyNewtype co tys) _ -> checkTapp t1 t2 _ -> checkTapp t1 t2) where checkTapp t1 t2 = do @@ -552,15 +554,17 @@ checkTyCo es t = do -- otherwise, expand by the "refl" rule _ -> return (t, t) -mlookupM :: (Eq a, Show a) => (Envs -> Env a b) -> Env a b -> Env a b -> Mname +mlookupM :: (Eq a, Show a, Show b) => (Envs -> Env a b) -> Env a b -> Env a b -> Mname -> CheckResult (Env a b) -mlookupM _ _ local_env Nothing = return local_env +mlookupM _ _ local_env Nothing = -- (trace ("mlookupM_: returning " ++ show local_env)) $ + return local_env mlookupM selector external_env local_env (Just m) = do mn <- getMname + globalEnv <- getGlobalEnv if m == mn - then return external_env - else do - globalEnv <- getGlobalEnv + then -- trace ("global env would b e " ++ show (elookup globalEnv m)) $ + return external_env + else case elookup globalEnv m of Just env' -> return (selector env') Nothing -> fail ("Check: undefined module name: " @@ -568,9 +572,27 @@ mlookupM selector external_env local_env (Just m) = do qlookupM :: (Ord a, Show a,Show b) => (Envs -> Env a b) -> Env a b -> Env a b -> Qual a -> CheckResult b -qlookupM selector external_env local_env (m,k) = - do env <- mlookupM selector external_env local_env m - lookupM env k +qlookupM selector external_env local_env v@(m,k) = + do env <- -- trace ("qlookupM: " ++ show v) $ + mlookupM selector external_env local_env m + -- argh, hack for unqualified top-level names + maybeRes <- lookupM env k + case maybeRes of + Just r -> return r + Nothing -> do mn <- getMname + currentMenv <- -- trace ("qlookupM: trying module for " ++ show mn) $ + mlookupM selector external_env local_env (Just mn) + maybeRes1 <- -- trace ("qlookupM: trying in " ++ show currentMenv) $ + lookupM currentMenv k + case maybeRes1 of + Just r1 -> return r1 + Nothing -> do + globalEnv <- getGlobalEnv + case elookup globalEnv mn of + Just e1 -> case elookup (selector e1) k of + Just r2 -> return r2 + Nothing -> fail ("Undefined id " ++ show v) + Nothing -> fail ("Undefined id " ++ show v) checkLit :: Lit -> CheckResult Ty checkLit (Literal lit t) = @@ -603,50 +625,6 @@ splitTy (Tapp(Tapp(Tcon tc) t0) t) | tc == tcArrow = (tbs,t0:ts,tr) splitTy t = ([],[],t) -{- Simultaneous substitution on types for type variables, - renaming as neceessary to avoid capture. - No checks for correct kindedness. -} -substl :: [Tvar] -> [Ty] -> Ty -> Ty -substl tvs ts t = f (zip tvs ts) t - where - f env t0 = - case t0 of - Tcon _ -> t0 - Tvar v -> case lookup v env of - Just t1 -> t1 - Nothing -> t0 - Tapp t1 t2 -> Tapp (f env t1) (f env t2) - Tforall (t,k) t1 -> - if t `elem` free then - Tforall (t',k) (f ((t,Tvar t'):env) t1) - else - Tforall (t,k) (f (filter ((/=t).fst) env) t1) - TransCoercion t1 t2 -> TransCoercion (f env t1) (f env t2) - SymCoercion t1 -> SymCoercion (f env t1) - UnsafeCoercion t1 t2 -> UnsafeCoercion (f env t1) (f env t2) - LeftCoercion t1 -> LeftCoercion (f env t1) - RightCoercion t1 -> RightCoercion (f env t1) - InstCoercion t1 t2 -> InstCoercion (f env t1) (f env t2) - where free = foldr union [] (map (freeTvars.snd) env) - t' = freshTvar free - -{- Return free tvars in a type -} -freeTvars :: Ty -> [Tvar] -freeTvars (Tcon _) = [] -freeTvars (Tvar v) = [v] -freeTvars (Tapp t1 t2) = freeTvars t1 `union` freeTvars t2 -freeTvars (Tforall (t,_) t1) = delete t (freeTvars t1) -freeTvars (TransCoercion t1 t2) = freeTvars t1 `union` freeTvars t2 -freeTvars (SymCoercion t) = freeTvars t -freeTvars (UnsafeCoercion t1 t2) = freeTvars t1 `union` freeTvars t2 -freeTvars (LeftCoercion t) = freeTvars t -freeTvars (RightCoercion t) = freeTvars t -freeTvars (InstCoercion t1 t2) = freeTvars t1 `union` freeTvars t2 - -{- Return any tvar *not* in the argument list. -} -freshTvar :: [Tvar] -> Tvar -freshTvar tvs = maximum ("":tvs) ++ "x" -- one simple way! - primCoercionError :: Show a => a -> b primCoercionError s = error $ "Bad coercion application: " ++ show s diff --git a/utils/ext-core/Language/Core/CoreUtils.hs b/utils/ext-core/Language/Core/CoreUtils.hs index 2967cd6..52d51f2 100644 --- a/utils/ext-core/Language/Core/CoreUtils.hs +++ b/utils/ext-core/Language/Core/CoreUtils.hs @@ -2,9 +2,13 @@ module Language.Core.CoreUtils where import Language.Core.Core import Language.Core.Utils +import Language.Core.Printer() + +--import Debug.Trace import Data.Generics import Data.List +import Data.Maybe splitDataConApp_maybe :: Exp -> Maybe (Qual Dcon, [Ty], [Exp]) splitDataConApp_maybe (Dcon d) = Just (d, [], []) @@ -56,11 +60,18 @@ vdefTys :: [Vdef] -> [Ty] vdefTys = map (\ (Vdef (_,t,_)) -> t) vdefgNames :: Vdefg -> [Var] -vdefgNames (Rec vds) = map (\ (Vdef ((_,v),_,_)) -> v) vds -vdefgNames (Nonrec (Vdef ((_,v),_,_))) = [v] +vdefgNames = snd . unzip . vdefgNamesQ + +vdefgNamesQ :: Vdefg -> [Qual Var] +vdefgNamesQ (Rec vds) = map (\ (Vdef (v,_,_)) -> v) vds +vdefgNamesQ (Nonrec (Vdef (v,_,_))) = [v] + vdefgTys :: Vdefg -> [Ty] vdefgTys (Rec vds) = map (\ (Vdef (_,t,_)) -> t) vds vdefgTys (Nonrec (Vdef (_,t,_))) = [t] +vdefgBodies :: Vdefg -> [Exp] +vdefgBodies (Rec vds) = map (\ (Vdef (_,_,e)) -> e) vds +vdefgBodies (Nonrec (Vdef (_,_,e))) = [e] vbNames :: [Vbind] -> [Var] vbNames = fst . unzip @@ -93,3 +104,109 @@ tdefTcons = concatMap doOne where doOne (Data qtc _ _) = [qtc] doOne (Newtype qtc qtc1 _ _) = [qtc, qtc1] +filterVdefgs :: (Vdef -> Bool) -> [Vdefg] -> [Vdefg] +filterVdefgs ok = catMaybes . (map dropNames) + where dropNames (Nonrec v) | not (ok v) = Nothing + dropNames v@(Nonrec _) = Just v + dropNames (Rec bs) = case filter ok bs of + [] -> Nothing + newBs -> Just (Rec newBs) + +applyNewtype :: CoercionKind -> [Ty] -> (Ty,Ty) +applyNewtype _d@(DefinedCoercion tbs (from,to)) tys = + let (tvs,_) = unzip tbs in + let res = (substl tvs tys from,substl tvs tys to) in + -- trace ("co = " ++ show d ++ " args = " ++ show tys ++ " res = " ++ show res) $ + res + +{- Simultaneous substitution on types for type variables, + renaming as neceessary to avoid capture. + No checks for correct kindedness. -} +substl :: [Tvar] -> [Ty] -> Ty -> Ty +substl tvs ts t = f (zip tvs ts) t + where + f env t0 = + case t0 of + Tcon _ -> t0 + Tvar v -> case lookup v env of + Just t1 -> t1 + Nothing -> t0 + Tapp t1 t2 -> Tapp (f env t1) (f env t2) + Tforall (tv,k) t1 -> + if tv `elem` free then + Tforall (t',k) (f ((tv,Tvar t'):env) t1) + else + Tforall (tv,k) (f (filter ((/=tv).fst) env) t1) + TransCoercion t1 t2 -> TransCoercion (f env t1) (f env t2) + SymCoercion t1 -> SymCoercion (f env t1) + UnsafeCoercion t1 t2 -> UnsafeCoercion (f env t1) (f env t2) + LeftCoercion t1 -> LeftCoercion (f env t1) + RightCoercion t1 -> RightCoercion (f env t1) + InstCoercion t1 t2 -> InstCoercion (f env t1) (f env t2) + where free = foldr union [] (map (freeTvars.snd) env) + t' = freshTvar free + + +{- Return free tvars in a type -} +freeTvars :: Ty -> [Tvar] +freeTvars (Tcon _) = [] +freeTvars (Tvar v) = [v] +freeTvars (Tapp t1 t2) = freeTvars t1 `union` freeTvars t2 +freeTvars (Tforall (t,_) t1) = delete t (freeTvars t1) +freeTvars (TransCoercion t1 t2) = freeTvars t1 `union` freeTvars t2 +freeTvars (SymCoercion t) = freeTvars t +freeTvars (UnsafeCoercion t1 t2) = freeTvars t1 `union` freeTvars t2 +freeTvars (LeftCoercion t) = freeTvars t +freeTvars (RightCoercion t) = freeTvars t +freeTvars (InstCoercion t1 t2) = freeTvars t1 `union` freeTvars t2 + +{- Return any tvar *not* in the argument list. -} +freshTvar :: [Tvar] -> Tvar +freshTvar tvs = maximum ("":tvs) ++ "x" -- one simple way! + +splitLambda :: Exp -> ([Bind],Exp) +splitLambda (Lam vb e) = case splitLambda e of + (vbs,rhs) -> (vb:vbs,rhs) +splitLambda (Note _ e) = splitLambda e +splitLambda e = ([],e) + +vbinds :: [Bind] -> [(Var,Ty)] +vbinds = foldl' stuff [] + where stuff :: [(Var,Ty)] -> Bind -> [(Var,Ty)] + stuff rest (Tb _) = rest + stuff rest (Vb p) = p:rest + +splitBinds :: [Bind] -> ([(Tvar,Kind)],[(Var,Ty)]) +splitBinds = foldr stuff ([],[]) + where stuff (Tb t) (tbs,vbs) = (t:tbs,vbs) + stuff (Vb v) (tbs,vbs) = (tbs,v:vbs) + +freeVars :: Exp -> [Qual Var] +freeVars (Var v) = [v] +freeVars (Dcon _) = [] +freeVars (Lit _) = [] +freeVars (App f g) = freeVars f `union` freeVars g +freeVars (Appt e _) = freeVars e +freeVars (Lam (Tb _) e) = freeVars e +freeVars (Lam (Vb (v,_)) e) = delete (unqual v) (freeVars e) +freeVars (Let (Nonrec (Vdef (v,_,rhs))) e) = freeVars rhs `union` (delete v (freeVars e)) +freeVars (Let r@(Rec _) e) = (freeVars e \\ boundVars) `union` (freeVarss rhss \\ boundVars) + where boundVars = map unqual $ vdefgNames r + rhss = vdefgBodies r +freeVars (Case e (v,_) _ alts) = freeVars e `union` (delete v1 (boundVarsAlts alts)) + where v1 = unqual v + boundVarsAlts as = freeVarss rhss \\ (v1:caseVars) + where rhss = map (\ a -> case a of + Acon _ _ _ r -> r + Alit _ r -> r + Adefault r -> r) as + caseVars = foldl' union [] (map (\ a -> case a of + Acon _ _ vbs _ -> + (map unqual (fst (unzip vbs))) + _ -> []) as) +freeVars (Cast e _) = freeVars e +freeVars (Note _ e) = freeVars e +freeVars (External {}) = [] + +freeVarss :: [Exp] -> [Qual Var] +freeVarss = foldl' union [] . map freeVars \ No newline at end of file diff --git a/utils/ext-core/Language/Core/ElimDeadCode.hs b/utils/ext-core/Language/Core/ElimDeadCode.hs index e32568e..8817edb 100644 --- a/utils/ext-core/Language/Core/ElimDeadCode.hs +++ b/utils/ext-core/Language/Core/ElimDeadCode.hs @@ -7,6 +7,7 @@ module Language.Core.ElimDeadCode(elimDeadCode) where import Language.Core.Core import Language.Core.Printer() +import Language.Core.CoreUtils import Language.Core.Utils import Control.Monad.Reader @@ -16,12 +17,15 @@ import Data.Maybe import qualified Data.Map as M import qualified Data.Set as S -elimDeadCode :: Module -> Module -elimDeadCode (Module mn tdefs vdefgs) = runReader (do +elimDeadCode :: Bool -> Module -> Module +-- exports = true <=> it's assumed we want to keep exported functions; +-- otherwise, we assume the module is "closed" and eliminate everything +-- not reachable from Main +elimDeadCode exports (Module mn tdefs vdefgs) = runReader (do (usedVars, usedDcons, usedTcons) <- findUsed emptySet - (mkStartSet mn vdefgs) + (mkStartSet exports mn vdefgs) let isUsed (Vdef (v,_,_)) = v `S.member` usedVars - let newVdefgs = [Rec $ filter isUsed (flattenBinds vdefgs)] + let newVdefgs = filterVdefgs isUsed vdefgs let newTdefs = filter (tdefIsUsed usedTcons usedDcons) tdefs in return $ Module mn newTdefs newVdefgs) ((mkVarEnv vdefgs), mkTyEnv tdefs) @@ -82,20 +86,19 @@ varsAndConsInOne' tc = do emptySet :: DeadSet emptySet = (S.empty, S.empty, S.empty) -mkStartSet :: AnMname -> [Vdefg] -> DeadSet +mkStartSet :: Bool -> AnMname -> [Vdefg] -> DeadSet -- Initially, we assume the definitions of any exported functions are not -- dead, and work backwards from there. -mkStartSet mn vds = - (S.fromList (filter ((== Just mn) . getModule) (exportedNames vds)), +mkStartSet exports mn vds = + (S.fromList (filter ((== Just mn) . getModule) (if exports then exportedNames vds else [mainVar])), S.empty, S.empty) exportedNames :: [Vdefg] -> [Qual Var] exportedNames vdefgs = let vds = flattenBinds vdefgs in - filter isQual (vdefNames vds) + filter isQual (ns vds) where isQual = isJust . fst - vdefNames = map (\ (Vdef (n,_,_)) -> n) - + ns = map (\ (Vdef (n,_,_)) -> n) type DeadSet = (S.Set (Qual Var), S.Set (Qual Dcon), S.Set (Qual Tcon)) type DeadM = Reader (M.Map (Qual Var) Exp, M.Map (Qual Tcon) [Ty]) diff --git a/utils/ext-core/Language/Core/Merge.hs b/utils/ext-core/Language/Core/Merge.hs index 0907aa7..18ad057 100644 --- a/utils/ext-core/Language/Core/Merge.hs +++ b/utils/ext-core/Language/Core/Merge.hs @@ -11,6 +11,7 @@ import Language.Core.Utils import Data.Char import Data.Generics import Data.List +import Data.Maybe {- merge turns a group of (possibly mutually recursive) modules @@ -38,7 +39,7 @@ import Data.List merge :: [(Qual Var, Qual Var)] -> [Module] -> Module merge subst ms = - zapNames subst topNames (Module mainMname newTdefs [Rec topBinds]) + zapNames subst topNames (Module mainMname newTdefs topBinds) where -- note: dead code elimination will later remove any names -- that were in the domain of the substitution newTdefs = finishTdefs deadIds $ concat allTdefs @@ -46,7 +47,7 @@ merge subst ms = -> (tds, vdefgs)) ms (deadIds,_) = unzip subst topNames = uniqueNamesIn topBinds (concat allTdefs) - topBinds = finishVdefs deadIds $ flattenBinds (concat allVdefgs) + (topBinds::[Vdefg]) = finishVdefs deadIds $ concat allVdefgs {- This function finds all of the names in the given group of vdefs and @@ -61,9 +62,9 @@ merge subst ms = (Both of those would allow for more names to be shortened, but aren't strictly necessary.) -} -uniqueNamesIn :: [Vdef] -> [Tdef] -> [Qual Var] +uniqueNamesIn :: [Vdefg] -> [Tdef] -> [Qual Var] uniqueNamesIn topBinds allTdefs = res - where vars = vdefNamesQ topBinds + where vars = vdefNamesQ (flattenBinds topBinds) dcons = tdefDcons allTdefs tcons = tdefTcons allTdefs uniqueVars = vars \\ dupsUnqual vars @@ -149,5 +150,6 @@ finishTdefs namesToDrop = filter isOkay && cdefsOkay cdefs cdefsOkay = all cdefOkay cdefOkay (Constr qdc _ _) = qdc `notElem` namesToDrop -finishVdefs :: [Qual Var] -> [Vdef] -> [Vdef] -finishVdefs namesToDrop = filter (\ (Vdef (qv,_,_)) -> qv `notElem` namesToDrop) +finishVdefs :: [Qual Var] -> [Vdefg] -> [Vdefg] +finishVdefs namesToDrop = filterVdefgs + (\ (Vdef (qv,_,_)) -> qv `notElem` namesToDrop) diff --git a/utils/ext-core/Language/Core/Prep.hs b/utils/ext-core/Language/Core/Prep.hs index 86b0155..a557b80 100644 --- a/utils/ext-core/Language/Core/Prep.hs +++ b/utils/ext-core/Language/Core/Prep.hs @@ -13,6 +13,8 @@ After these preprocessing steps, Core can be interpreted (or given an operationa module Language.Core.Prep where +--import Debug.Trace + import Control.Monad.State import Data.Either import Data.List @@ -20,6 +22,7 @@ import Data.Generics import qualified Data.Map as M import Language.Core.Core +import Language.Core.CoreUtils import Language.Core.Env import Language.Core.Check import Language.Core.Environments @@ -97,8 +100,6 @@ prepModule globalEnv (Module mn tdefs vdefgs) = prepAlt env (Alit l e) = (liftM (Alit l)) (prepExp env e) prepAlt env (Adefault e) = (liftM Adefault) (prepExp env e) - ntEnv = mkNtEnv globalEnv - unwindApp :: (Venv, Tvenv) -> Exp -> [Either Exp Ty] -> PrepM Exp unwindApp env (App e1 e2) as = unwindApp env e1 (Left e2:as) unwindApp env (Appt e t) as = unwindApp env e (Right t:as) @@ -110,41 +111,9 @@ prepModule globalEnv (Module mn tdefs vdefgs) = atys = map (substl (map fst tbs) ts) atys0 ts = [t | Right t <- as] n = length [e | Left e <- as] - unwindApp env (op@(Var(qv@(_,p)))) as | isPrimVar qv = do + unwindApp env (op@(Var qv)) as | isPrimVar qv = do e' <- rewindApp env op as - (liftM k) $ etaExpand (snd (unzip extraTbs)) (drop n atys) (k1 e') - where -- TODO: avoid copying code. these two cases are the same - - -- etaExpand needs to add the type arguments too! Bah! - primEnv = case elookup globalEnv primMname of - Just es -> venv_ es - _ -> error "eek" - (_, _, resTy') = (maybe (error "unwindApp") splitTy (elookup primEnv p)) - (tbs, atys0, _resTy) = (maybe (error "unwindApp") (splitTy . (substNewtys ntEnv)) (elookup primEnv p)) - -- The magic here is so we know to eta-expand applications of - -- primops whose return types are newtypes. - -- There are no actual GHC primops that have this property, but - -- a back-end tool writer (for example: me) might want to add - -- such a primop. - -- If this code wasn't here, and we had a primop - -- foo# :: Int -> IO (), - -- we would see (foo# 5) and think it was fully applied, when - -- actually we need to rewrite it as: - -- (\ (s::State# RealWorld#) -> foo# 5 s) - -- (This code may be a very good case against introducing such - -- primops.) - -- tim 10/29/2008: I think this is no longer necessary. - -- hPutChar now has a (#wub,blub#) return type. - (k,k1) = case newtypeCoercion_maybe ntEnv resTy' of - Just co -> case splitTyConApp_maybe resTy' of - Just (_, args) -> ((\ e -> Cast e (SymCoercion (mkTapp co args))), (\ e1 -> Cast e1 (mkTapp co args))) - _ -> ((\ e -> Cast e (SymCoercion co)), (\ e1 -> Cast e1 co)) - _ -> (id,id) - 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] + etaExpand [] [] e' unwindApp env (op@(External _ t)) as = do e' <- rewindApp env op as etaExpand [] (drop n atys) e' @@ -241,36 +210,21 @@ boundVarsAlt (Acon _ _ vbs e) = (map fst vbs) `union` (boundVars e) boundVarsAlt (Alit _ e) = boundVars e boundVarsAlt (Adefault e) = boundVars e -mkNtEnv :: Menv -> NtEnv -mkNtEnv menv = - foldl M.union M.empty $ - map (\ (mn,e) -> - foldr (\ (key,thing) rest -> - case thing of - Kind _ -> rest - Coercion (DefinedCoercion _ (lhs,rhs)) -> - case splitTyConApp_maybe lhs of - Just ((_,tc1),_) -> M.insert tc1 (rhs,Tcon (Just mn, key)) rest - _ -> rest) M.empty (etolist (tcenv_ e))) (etolist menv) - substNewtys :: NtEnv -> Ty -> Ty substNewtys ntEnv = everywhere'Except (mkT go) - where go t | Just ((_,tc),_) <- splitTyConApp_maybe t = + where go t | Just ((_,tc),args) <- splitTyConApp_maybe t = case M.lookup tc ntEnv of - Just (rhs,_) -> rhs + Just d -> -- trace ("applying newtype: " ++ show t) $ + (snd (applyNewtype d args)) Nothing -> t go t = t -newtypeCoercion_maybe :: NtEnv -> Ty -> Maybe Ty -newtypeCoercion_maybe ntEnv t | Just ((_,tc),_) <- splitTyConApp_maybe t = - case M.lookup tc ntEnv of - Just (_, coercion) -> Just coercion - Nothing -> Nothing +newtypeCoercion_maybe :: NtEnv -> Ty -> Maybe CoercionKind +newtypeCoercion_maybe ntEnv t | Just ((_,tc),_) <- splitTyConApp_maybe t = + M.lookup tc ntEnv newtypeCoercion_maybe _ _ = Nothing --- first element: rep type --- second element: coercion tcon -type NtEnv = M.Map Tcon (Ty, Ty) +type NtEnv = M.Map Tcon CoercionKind mkTapp :: Ty -> [Ty] -> Ty mkTapp = foldl Tapp diff --git a/utils/ext-core/Language/Core/Printer.hs b/utils/ext-core/Language/Core/Printer.hs index 4fef854..d7c4cdb 100644 --- a/utils/ext-core/Language/Core/Printer.hs +++ b/utils/ext-core/Language/Core/Printer.hs @@ -35,6 +35,11 @@ instance Show Ty where instance Show Kind where showsPrec _ k = shows (pkind k) +instance Show CoercionKind where + showsPrec _ (DefinedCoercion tbs (from,to)) = + shows $ parens (text "defined coercion:" <+> (hsep (map ptbind tbs)) + <+> text ":" <+> brackets (pty from) + <+> text "->" <+> brackets (pty to)) instance Show Lit where showsPrec _ l = shows (plit l) diff --git a/utils/ext-core/Language/Core/Utils.hs b/utils/ext-core/Language/Core/Utils.hs index 3ffabf2..d5ca785 100644 --- a/utils/ext-core/Language/Core/Utils.hs +++ b/utils/ext-core/Language/Core/Utils.hs @@ -33,7 +33,7 @@ everywhere'But :: GenericQ Bool -> GenericT -> GenericT -- Guarded to let traversal cease if predicate q holds for x everywhere'But q f x | q x = x - | otherwise = let top = gmapT f x in + | otherwise = let top = f x in top `seq` (gmapT (everywhere'But q f) top) everywhereButM :: Monad m => GenericQ Bool -> GenericM m -> GenericM m diff --git a/utils/ext-core/extcore.cabal b/utils/ext-core/extcore.cabal index 5a6b7dc..bb17b81 100644 --- a/utils/ext-core/extcore.cabal +++ b/utils/ext-core/extcore.cabal @@ -13,8 +13,8 @@ data-files: README build-type: Simple cabal-version: >=1.2 Library { - exposed-modules: Language.Core.Check, Language.Core.Dependencies, Language.Core.Core, Language.Core.Interp, Language.Core.Overrides, Language.Core.ParsecParser, Language.Core.Prep, Language.Core.Prims, Language.Core.Printer, Language.Core.Merge, Language.Core.ElimDeadCode, Language.Core.Encoding, Language.Core.Env - other-modules: Language.Core.PrimCoercions, Language.Core.PrimEnv, Language.Core.Utils, Language.Core.CoreUtils, Language.Core.Environments + exposed-modules: Language.Core.Check, Language.Core.Dependencies, Language.Core.Core, Language.Core.Interp, Language.Core.Overrides, Language.Core.ParsecParser, Language.Core.Prep, Language.Core.Prims, Language.Core.Printer, Language.Core.Merge, Language.Core.ElimDeadCode, Language.Core.Encoding, Language.Core.Env, Language.Core.CoreUtils + other-modules: Language.Core.PrimCoercions, Language.Core.PrimEnv, Language.Core.Utils, Language.Core.Environments extensions: DeriveDataTypeable PatternGuards RankNTypes ScopedTypeVariables ghc-options: -Wall -O2 build-depends: base, containers, directory, filepath, mtl, parsec, pretty -- 1.7.10.4