Commit 460784c3 authored by chevalier@alum.wellesley.edu's avatar chevalier@alum.wellesley.edu
Browse files

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.
parent 4260f0c9
......@@ -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
......
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
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment