From 460784c371813cb92eac71df403fe34258c8f3b8 Mon Sep 17 00:00:00 2001 From: Tim Chevalier Date: Sat, 9 Aug 2008 00:20:51 +0000 Subject: [PATCH] Fixed performance bug in ext-core preprocessor The Core preprocessor was rebuilding the type and data constructor environments every time it called the typechecker, which was horribly inefficient. Fixed. --- utils/ext-core/Language/Core/Check.hs | 36 +++++++++----------------- utils/ext-core/Language/Core/Environments.hs | 19 ++++++++++++++ utils/ext-core/Language/Core/Prep.hs | 35 +++++++++++++------------ utils/ext-core/Setup.lhs | 2 +- 4 files changed, 51 insertions(+), 41 deletions(-) create mode 100644 utils/ext-core/Language/Core/Environments.hs diff --git a/utils/ext-core/Language/Core/Check.hs b/utils/ext-core/Language/Core/Check.hs index db15601..2331ea0 100644 --- a/utils/ext-core/Language/Core/Check.hs +++ b/utils/ext-core/Language/Core/Check.hs @@ -4,12 +4,14 @@ module Language.Core.Check( checkExpr, checkType, primCoercionError, Menv, Venv, Tvenv, Envs(..), - CheckRes(..), splitTy, substl) where + CheckRes(..), splitTy, substl, + mkTypeEnvsNoChecking) where import Language.Core.Core import Language.Core.Printer() import Language.Core.PrimEnv import Language.Core.Env +import Language.Core.Environments import Control.Monad.Reader import Data.List @@ -40,19 +42,6 @@ require :: Bool -> String -> CheckResult () require False s = fail s require True _ = return () -{- Environments. -} -type Tvenv = Env Tvar Kind -- type variables (local only) -type Tcenv = Env Tcon KindOrCoercion -- type constructors -type Cenv = Env Dcon Ty -- data constructors -type Venv = Env Var Ty -- values -type Menv = Env AnMname Envs -- modules -data Envs = Envs {tcenv_::Tcenv,cenv_::Cenv,venv_::Venv} -- all the exportable envs - deriving Show - -{- Extend an environment, checking for illegal shadowing of identifiers (for term - variables -- shadowing type variables is allowed.) -} -data EnvType = Tv | NotTv - deriving Eq extendM :: (Ord a, Show a) => EnvType -> Env a b -> (a,b) -> CheckResult (Env a b) extendM envType env (k,d) = @@ -71,7 +60,7 @@ 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) + Nothing -> fail ("undefined identifier: " ++ show k ++ " e = " ++ show (edomain env)) {- Main entry point. -} checkModule :: Menv -> Module -> CheckRes Menv @@ -258,26 +247,25 @@ vdefIsMainWrapper :: AnMname -> Mname -> Bool vdefIsMainWrapper enclosing defining = enclosing == mainMname && defining == wrapperMainAnMname -checkExpr :: AnMname -> Menv -> [Tdef] -> Venv -> Tvenv +checkExpr :: AnMname -> Menv -> Tcenv -> Cenv -> Venv -> Tvenv -> Exp -> Ty -checkExpr mn menv tdefs venv tvenv e = case runReaderT (do - (tcenv, cenv) <- mkTypeEnvs tdefs +checkExpr mn menv _tcenv _cenv venv tvenv e = case runReaderT (do + --(tcenv, cenv) <- mkTypeEnvs tdefs -- Since the preprocessor calls checkExpr after code has been -- typechecked, we expect to find the external env in the Menv. case (elookup menv mn) of Just thisEnv -> - checkExp (tcenv, tvenv, cenv, (venv_ thisEnv), venv) e + checkExp ({-tcenv-}tcenv_ thisEnv, tvenv, {-cenv-}cenv_ thisEnv, (venv_ thisEnv), venv) e Nothing -> reportError e ("checkExpr: Environment for " ++ show mn ++ " not found")) (mn,menv) of OkC t -> t FailC s -> reportError e s -checkType :: AnMname -> Menv -> [Tdef] -> Tvenv -> Ty -> Kind -checkType mn menv tdefs tvenv t = case runReaderT (do - (tcenv, _) <- mkTypeEnvs tdefs - checkTy (tcenv, tvenv) t) (mn, menv) of +checkType :: AnMname -> Menv -> Tcenv -> Tvenv -> Ty -> Kind +checkType mn menv _tcenv tvenv t = + case runReaderT (checkTy (tcenv_ (fromMaybe (error "checkType") (elookup menv mn)), tvenv) t) (mn, menv) of OkC k -> k - FailC s -> reportError tvenv s + FailC s -> reportError tvenv (s ++ "\n " ++ show menv ++ "\n mname =" ++ show mn) checkExp :: (Tcenv,Tvenv,Cenv,Venv,Venv) -> Exp -> CheckResult Ty checkExp (tcenv,tvenv,cenv,e_venv,l_venv) = ch diff --git a/utils/ext-core/Language/Core/Environments.hs b/utils/ext-core/Language/Core/Environments.hs new file mode 100644 index 0000000..47ba594 --- /dev/null +++ b/utils/ext-core/Language/Core/Environments.hs @@ -0,0 +1,19 @@ +module Language.Core.Environments where + +import Language.Core.Env +import Language.Core.Core +import Language.Core.Printer() + +{- Environments. -} +type Tvenv = Env Tvar Kind -- type variables (local only) +type Tcenv = Env Tcon KindOrCoercion -- type constructors +type Cenv = Env Dcon Ty -- data constructors +type Venv = Env Var Ty -- values +type Menv = Env AnMname Envs -- modules +data Envs = Envs {tcenv_::Tcenv,cenv_::Cenv,venv_::Venv} -- all the exportable envs + deriving Show + +{- Extend an environment, checking for illegal shadowing of identifiers (for term + variables -- shadowing type variables is allowed.) -} +data EnvType = Tv | NotTv + deriving Eq diff --git a/utils/ext-core/Language/Core/Prep.hs b/utils/ext-core/Language/Core/Prep.hs index e6f015f..de29bb7 100644 --- a/utils/ext-core/Language/Core/Prep.hs +++ b/utils/ext-core/Language/Core/Prep.hs @@ -18,13 +18,16 @@ import Language.Core.Prims import Language.Core.Core import Language.Core.Env import Language.Core.Check +import Language.Core.Environments +import Language.Core.Encoding prepModule :: Menv -> Module -> Module prepModule globalEnv (Module mn tdefs vdefgs) = Module mn tdefs vdefgs' where - (_,vdefgs') = foldl prepTopVdefg (eempty,[]) vdefgs + (tcenv, cenv) = mkTypeEnvsNoChecking tdefs + (_,vdefgs') = foldl' prepTopVdefg (eempty,[]) vdefgs prepTopVdefg (venv,vdefgs) vdefg = (venv',vdefgs ++ [vdefg']) where (venv',vdefg') = prepVdefg (venv,eempty) vdefg @@ -35,7 +38,7 @@ prepModule globalEnv (Module mn tdefs vdefgs) = (venv, Nonrec(Vdef(qx,t,prepExp env e))) prepVdefg (venv,tvenv) (Rec vdefs) = (venv',Rec [ Vdef(qx,t,prepExp (venv',tvenv) e) | Vdef(qx,t,e) <- vdefs]) - where venv' = foldl eextend venv [(x,t) | Vdef((Nothing,x),t,_) <- vdefs] + where venv' = foldl' eextend venv [(x,t) | Vdef((Nothing,x),t,_) <- vdefs] prepExp _ (Var qv) = Var qv prepExp _ (Dcon qdc) = Dcon qdc @@ -51,7 +54,7 @@ prepModule globalEnv (Module mn tdefs vdefgs) = -- We need to know the type of the let body in order to construct -- a case expression. -- need to extend the env with the let-bound var too! - let eTy = typeOfExp (eextend venv (x, t), tvenv) e in + let eTy = typeOfExp (eextend venv (x, t)) tvenv e in Case (prepExp env b) (x,t) eTy [Adefault (prepExp (eextend venv (x,t),tvenv) e)] @@ -62,7 +65,7 @@ prepModule globalEnv (Module mn tdefs vdefgs) = prepExp env (Note s e) = Note s (prepExp env e) prepExp _ (External s t) = External s t - prepAlt (venv,tvenv) (Acon qdc tbs vbs e) = Acon qdc tbs vbs (prepExp (foldl eextend venv vbs,foldl eextend tvenv tbs) e) + prepAlt (venv,tvenv) (Acon qdc tbs vbs e) = Acon qdc tbs vbs (prepExp (foldl' eextend venv vbs,foldl' eextend tvenv tbs) e) prepAlt env (Alit l e) = Alit l (prepExp env e) prepAlt env (Adefault e) = Adefault (prepExp env e) @@ -93,12 +96,12 @@ prepModule globalEnv (Module mn tdefs vdefgs) = etaExpand :: [Kind] -> [Ty] -> Exp -> Exp etaExpand ks ts e = -- what a pain - let tyArgs = [("$t_"++(show i),k) | (i, k) <- zip [(1::Integer)..] ks] - termArgs = [ ('$':(show i),t) | (i,t) <- zip [(1::Integer)..] ts] in + let tyArgs = [(zEncodeString $ "$t_"++(show i),k) | (i, k) <- zip [(1::Integer)..] ks] + termArgs = [ (zEncodeString $ '$':(show i),t) | (i,t) <- zip [(1::Integer)..] ts] in foldr (\ (t1,k1) e -> Lam (Tb (t1,k1)) e) (foldr (\ (v,t) e -> Lam (Vb (v,t)) e) - (foldl (\ e (v,_) -> App e (Var (unqual v))) - (foldl (\ e (tv,_) -> Appt e (Tvar tv)) + (foldl' (\ e (v,_) -> App e (Var (unqual v))) + (foldl' (\ e (tv,_) -> Appt e (Tvar tv)) e tyArgs) termArgs) termArgs) tyArgs @@ -106,9 +109,9 @@ prepModule globalEnv (Module mn tdefs vdefgs) = rewindApp _ e [] = e rewindApp env@(venv,tvenv) e1 (Left e2:as) | kindOfTy tvenv t `eqKind` Kunlifted && suspends e2 = -- This is the other place where we call the typechecker. - Case newScrut (v,t) (typeOfExp env' rhs) [Adefault rhs] + Case newScrut (v,t) (typeOfExp venv' tvenv rhs) [Adefault rhs] where newScrut = prepExp env e2 - rhs = (rewindApp env' (App e1 (Var (unqual v))) as) + rhs = (rewindApp (venv', tvenv) (App e1 (Var (unqual v))) as) -- note: -- e1 gets moved inside rhs. so if we pick a case -- var name (outside e1) equal to a name bound *inside* @@ -117,18 +120,18 @@ prepModule globalEnv (Module mn tdefs vdefgs) = -- So, we pass the bound vars of e1 to freshVar along with -- the domain of the current env. v = freshVar (edomain venv `union` (boundVars e1)) - t = typeOfExp env e2 - env' = (eextend venv (v,t),tvenv) + t = typeOfExp venv tvenv e2 + venv' = eextend venv (v,t) rewindApp env e1 (Left e2:as) = rewindApp env (App e1 (prepExp env e2)) as rewindApp env e (Right t:as) = rewindApp env (Appt e t) as freshVar vs = maximum ("":vs) ++ "x" -- one simple way! - - typeOfExp :: (Venv, Tvenv) -> Exp -> Ty - typeOfExp = uncurry (checkExpr mn globalEnv tdefs) + + typeOfExp :: Venv -> Tvenv -> Exp -> Ty + typeOfExp = checkExpr mn globalEnv tcenv cenv kindOfTy :: Tvenv -> Ty -> Kind - kindOfTy tvenv = checkType mn globalEnv tdefs tvenv + kindOfTy tvenv = checkType mn globalEnv tcenv tvenv {- Return false for those expressions for which Interp.suspendExp builds a thunk. -} suspends (Var _) = False diff --git a/utils/ext-core/Setup.lhs b/utils/ext-core/Setup.lhs index 806e9ff..f7706b8 100644 --- a/utils/ext-core/Setup.lhs +++ b/utils/ext-core/Setup.lhs @@ -44,7 +44,7 @@ build_primitive_sources f pd lbi uhs x primEnvExists <- doesFileExist primhs genprimopcodeExists <- doesFileExist genprimopcode primopsExists <- doesFileExist primops - unless (primEnvExists && !genprimopcodeExists && !primopsExists) do + unless (primEnvExists && not genprimopcodeExists && not primopsExists) $ do maybeExit $ system (genprimopcode ++ " --make-ext-core-source < " ++ primops ++ " > " ++ primhs_tmp) maybeUpdateFile primhs_tmp primhs -- 1.7.10.4