import StgInterp ( runStgI )
\end{code}
+
+%************************************************************************
+%* *
+\subsection{The main compiler pipeline}
+%* *
+%************************************************************************
+
\begin{code}
hscMain
:: DynFlags
= 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
\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:
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}
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
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}
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}
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}
}
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
}
= 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'';
= 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:
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
})}
\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}
-- 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],
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)
}
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:
= 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
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.
(\ 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 $
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' ->
projects / ghc-hetmet.git / commitdiff