Commit db7db1b4 authored by simonpj's avatar simonpj

[project @ 2000-10-12 15:05:59 by simonpj]

More of Simon
parent 90a24e7d
......@@ -49,6 +49,13 @@ import NativeInfo ( os, arch )
import StgInterp ( runStgI )
\end{code}
%************************************************************************
%* *
\subsection{The main compiler pipeline}
%* *
%************************************************************************
\begin{code}
hscMain
:: DynFlags
......@@ -223,7 +230,50 @@ hscMain flags core_cmds stg_cmds summary maybe_old_iface
= if opt_D_show_passes
then \ what -> hPutStr stderr ("*** "++what++":\n")
else \ what -> return ()
\end{code}
%************************************************************************
%* *
\subsection{Initial persistent state}
%* *
%************************************************************************
\begin{code}
initPersistentCompilerState :: PersistentCompilerState
initPersistentCompilerState
= PCS { pcsPST = initPackageDetails,
pcsInsts = emptyInstEnv,
pcsRules = emptyRuleEnv,
pcsPRS = initPersistentRenamerState }
initPackageDetails :: PackageSymbolTable
initPackageDetails = extendTypeEnv emptyModuleEnv (map ATyCon wiredInTyCons)
initPersistentRenamerState :: PersistentRenamerState
= PRS { prsNS = NS { nsNames = initRenamerNames,
nsIParam = emptyFM },
prsDecls = emptyNameEnv,
prsInsts = emptyBag,
prsRules = emptyBag
}
initRenamerNames :: FiniteMap (ModuleName,OccName) Name
initRenamerNames = grag wiredIn_in `plusFM` listToFM known_key
where
wired_in = [ ((moduleName (nameModule name), nameOccName name), name)
| name <- wiredInNames ]
known_key = [ ((rdrNameModule rdr_name, rdrNameOcc rdr_name), mkKnownKeyGlobal rdr_name uniq)
| (rdr_name, uniq) <- knownKeyRdrNames ]
%************************************************************************
%* *
\subsection{Statistics}
%* *
%************************************************************************
\begin{code}
ppSourceStats short (HsModule name version exports imports decls _ src_loc)
= (if short then hcat else vcat)
(map pp_val
......
......@@ -22,16 +22,29 @@ A @ModDetails@ summarises everything we know about a compiled module
\begin{code}
data ModDetails
= ModDetails {
moduleId :: Module,
moduleExports :: Avails, -- What it exports
moduleEnv :: GlobalRdrEnv, -- Its top level environment
fixityEnv :: NameEnv Fixity,
deprecEnv :: NameEnv DeprecTxt,
typeEnv :: NameEnv TyThing, -- TyThing is in TcEnv.lhs
typeEnv :: TypeEnv,
instEnv :: InstEnv,
ruleEnv :: IdEnv [CoreRule] -- Domain includes Ids from other modules
ruleEnv :: RuleEnv -- Domain may include Id from other modules
}
emptyModDetails :: Module -> ModuleDetails
emptyModDetails mod
= ModDetails { moduleId = mod,
moduleExports = [],
moduleEnv = emptyRdrEnv,
fixityEnv = emptyNameEnv,
deptecEnv = emptyNameEnv,
typeEnv = emptyNameEnv,
instEnv = emptyInstEnv,
} ruleEnv = emptyRuleEnv
\end{code}
Symbol tables map modules to ModDetails:
......@@ -55,12 +68,60 @@ lookupFixityEnv tbl name
Just details -> case lookupNameEnv (fixityEnv details) name of
Just fixity -> fixity
Nothing -> defaultFixity
\end{code}
%************************************************************************
%* *
\subsection{Type environment stuff}
%* *
%************************************************************************
\begin{code}
type TypeEnv = NameEnv TyThing
data TyThing = AnId Id
| ATyCon TyCon
| AClass Class
instance NamedThing TyThing where
getName (AnId id) = getName id
getName (ATyCon tc) = getName tc
getName (AClass cl) = getName cl
\end{code}
\begin{code}
lookupTypeEnv :: SymbolTable -> Name -> Maybe TyThing
lookupTypeEnv tbl name
= case lookupModuleEnv tbl (nameModule name) of
Just details -> lookupNameEnv (typeEnv details) name
Nothing -> Nothing
groupTyThings :: [TyThing] -> [(Module, TypeEnv)]
groupTyThings things
= fmToList (foldl add emptyFM things)
where
add :: FiniteMap Module TypeEnv -> TyThing -> FiniteMap Module TypeEnv
add tbl thing = addToFM tbl mod new_env
where
name = getName thing
mod = nameModule name
new_env = case lookupFM tbl mod of
Nothing -> unitNameEnv name thing
Just env -> extendNameEnv env name thing
extendTypeEnv :: SymbolTable -> [TyThing] -> SymbolTable
extendTypeEnv tbl things
= foldl add tbl (groupTyThings things)
where
add tbl (mod,type_env)
= extendModuleEnv mod new_details
where
new_details = case lookupModuleEnv tbl mod of
Nothing -> emptyModDetails mod {typeEnv = type_env}
Just details -> details {typeEnv = typeEnv details `plusNameEnv` type_env})
\end{code}
......@@ -74,10 +135,6 @@ These types are defined here because they are mentioned in ModDetails,
but they are mostly elaborated elsewhere
\begin{code}
data TyThing = AnId Id
| ATyCon TyCon
| AClass Class
type DeprecationEnv = NameEnv DeprecTxt -- Give reason for deprecation
type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name clashes
......@@ -86,6 +143,8 @@ type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name c
type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class
type ClsInstEnv = [(TyVarSet, [Type], Id)] -- The instances for a particular class
type RuleEnv = IdEnv [CoreRule]
\end{code}
......@@ -143,6 +202,11 @@ data ModIFace
data PersistentCompilerState
= PCS {
pcsPST :: PackageSymbolTable, -- Domain = non-home-package modules
-- except that the InstEnv components is empty
pcsInsts :: InstEnv -- The total InstEnv accumulated from all
-- the non-home-package modules
pcsRules :: RuleEnv -- Ditto RuleEnv
pcsPRS :: PersistentRenamerState
}
\end{code}
......@@ -151,10 +215,19 @@ The @PersistentRenamerState@ persists across successive calls to the
compiler.
It contains:
* a name supply, which deals with allocating unique names to
* A name supply, which deals with allocating unique names to
(Module,OccName) original names,
* a "holding pen" for declarations that have been read out of
* An accumulated InstEnv from all the modules in pcsPST
The point is that we don't want to keep recreating it whenever
we compile a new module. The InstEnv component of pcPST is empty.
(This means we might "see" instances that we shouldn't "really" see;
but the Haskell Report is vague on what is meant to be visible,
so we just take the easy road here.)
* Ditto for rules
* A "holding pen" for declarations that have been read out of
interface files but not yet sucked in, renamed, and typechecked
\begin{code}
......@@ -166,8 +239,7 @@ data PersistentRenamerState
}
data NameSupply
= NS { nsUniqs :: UniqSupply,
nsNames :: FiniteMap (Module,OccName) Name -- Ensures that one original name gets one unique
= NS { nsNames :: FiniteMap (Module,OccName) Name -- Ensures that one original name gets one unique
nsIParam :: FiniteMap OccName Name -- Ensures that one implicit parameter name gets one unique
}
......
......@@ -386,14 +386,6 @@ initIfaceRnMS mod thing_inside
= initRnMS emptyRdrEnv emptyNameEnv InterfaceMode $
setModuleRn mod thing_inside
builtins :: FiniteMap (ModuleName,OccName) Name
builtins = listToFM wired_in `plusFM` listToFM known_key
where
wired_in = [ ((moduleName (nameModule name), nameOccName name), name)
| name <- wiredInNames ]
known_key = [ ((rdrNameModule rdr_name, rdrNameOcc rdr_name), mkKnownKeyGlobal rdr_name uniq)
| (rdr_name, uniq) <- knownKeyRdrNames ]
\end{code}
@renameSourceCode@ is used to rename stuff ``out-of-line'';
......
......@@ -87,7 +87,7 @@ data TcEnv
= TcEnv {
tcGST :: GlobalSymbolTable, -- The symbol table at the moment we began this compilation
tcInst :: InstEnv, -- All instances (both imported and in this module)
tcInsts :: InstEnv, -- All instances (both imported and in this module)
tcGEnv :: NameEnv TyThing -- The global type environment we've accumulated while
-- compiling this module:
......@@ -141,10 +141,10 @@ data TcTyThing
initTcEnv :: GlobalSymbolTable -> InstEnv -> IO TcEnv
initTcEnv gst inst_env
= do { gtv_var <- newIORef emptyVarSet
return (TcEnv { tcGST = gst,
tcGEnv = emptyNameEnv,
tcInst = inst_env,
tcLEnv = emptyNameEnv,
return (TcEnv { tcGST = gst,
tcGEnv = emptyNameEnv,
tcInsts = inst_env,
tcLEnv = emptyNameEnv,
tcTyVars = gtv_var
})}
......@@ -469,12 +469,12 @@ tcGetGlobalTyVars
\begin{code}
tcGetInstEnv :: NF_TcM InstEnv
tcGetInstEnv = tcGetEnv `thenNF_Tc` \ env ->
returnNF_Tc (tcInst env)
returnNF_Tc (tcInsts env)
tcSetInstEnv :: InstEnv -> TcM a -> TcM a
tcSetInstEnv ie thing_inside
= tcGetEnv `thenNF_Tc` \ env ->
tcSetEnv (env {tcInst = ie}) thing_inside
tcSetEnv (env {tcInsts = ie}) thing_inside
\end{code}
......
......@@ -68,6 +68,8 @@ Outside-world interface:
-- Convenient type synonyms first:
data TcResults
= TcResults {
tc_prs :: PersistentCompilerState, -- Augmented with imported information,
-- (but not stuff from this module)
tc_binds :: TypecheckedMonoBinds,
tc_tycons :: [TyCon],
tc_classes :: [Class],
......@@ -87,7 +89,7 @@ typecheckModule
typecheckModule pcs hst mod
= do { us <- mkSplitUniqSupply 'a' ;
env <- initTcEnv gst inst_env ;
env <- initTcEnv global_symbol_table global_inst_env ;
(maybe_result, warns, errs) <- initTc us env (tcModule (pcsPRS pcs) mod)
......@@ -106,6 +108,10 @@ typecheckModule pcs hst mod
}
where
global_symbol_table = pcsPST pcs `plusModuleEnv` hst
global_inst_env = foldModuleEnv (plusInstEnv . instEnv) (pcsInsts pcs) gst
-- For now, make the total instance envt by simply
-- folding together all the instances we can find anywhere
\end{code}
The internal monster:
......@@ -118,15 +124,15 @@ tcModule prs (HsModule mod_name _ _ _ decls _ src_loc)
= tcAddSrcLoc src_loc $ -- record where we're starting
fixTc (\ ~(unf_env ,_) ->
-- unf_env is used for type-checking interface pragmas
-- (unf_env :: TcEnv) is used for type-checking interface pragmas
-- which is done lazily [ie failure just drops the pragma
-- without having any global-failure effect].
--
-- unf_env is also used to get the pragam info
-- unf_env is also used to get the pragama info
-- for imported dfuns and default methods
-- Type-check the type and class decls
tcTyAndClassDecls unf_env decls `thenTc` \ env ->
tcTyAndClassDecls unf_env decls `thenTc` \ env ->
tcSetEnv env $
-- Typecheck the instance decls, includes deriving
......@@ -183,7 +189,7 @@ tcModule prs (HsModule mod_name _ _ _ decls _ src_loc)
tcExtendGlobalValEnv cls_ids $
-- foreign import declarations next.
tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
tcExtendGlobalValEnv fo_ids $
-- Value declarations next.
......@@ -192,7 +198,6 @@ tcModule prs (HsModule mod_name _ _ _ decls _ src_loc)
(\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing))
(get_val_decls decls `ThenBinds` deriv_binds)
( tcGetEnv `thenNF_Tc` \ env ->
tcGetUnique `thenNF_Tc` \ uniq ->
returnTc ((EmptyMonoBinds, env), emptyLIE)
) `thenTc` \ ((val_binds, final_env), lie_valdecls) ->
tcSetEnv final_env $
......@@ -245,6 +250,8 @@ tcModule prs (HsModule mod_name _ _ _ decls _ src_loc)
in
zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) ->
tcSetEnv really_final_env $
-- zonkTopBinds puts all the top-level Ids into the tcGEnv
zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
zonkRules rules `thenNF_Tc` \ rules' ->
......
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