Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Shayne Fletcher
Glasgow Haskell Compiler
Commits
db7db1b4
Commit
db7db1b4
authored
Oct 12, 2000
by
simonpj
Browse files
[project @ 2000-10-12 15:05:59 by simonpj]
More of Simon
parent
90a24e7d
Changes
5
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/main/HscMain.lhs
View file @
db7db1b4
...
...
@@ -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
...
...
ghc/compiler/main/HscTypes.lhs
View file @
db7db1b4
...
...
@@ -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 ::
Nam
eEnv
TyThing, -- TyThing is in TcEnv.lhs
typeEnv ::
Typ
eEnv
,
instEnv :: InstEnv,
ruleEnv ::
IdEnv [CoreRule]
-- Domain include
s
Id
s
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
}
...
...
ghc/compiler/rename/RnMonad.lhs
View file @
db7db1b4
...
...
@@ -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'';
...
...
ghc/compiler/typecheck/TcEnv.lhs
View file @
db7db1b4
...
...
@@ -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)
tcInst
s
:: 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,
tcInst
s
= 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 (tcInst
s
env)
tcSetInstEnv :: InstEnv -> TcM a -> TcM a
tcSetInstEnv ie thing_inside
= tcGetEnv `thenNF_Tc` \ env ->
tcSetEnv (env {tcInst = ie}) thing_inside
tcSetEnv (env {tcInst
s
= ie}) thing_inside
\end{code}
...
...
ghc/compiler/typecheck/TcModule.lhs
View file @
db7db1b4
...
...
@@ -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 g
st
inst_env ;
env <- initTcEnv g
lobal_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 pragam
a
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' ->
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment