Commit d893f380 authored by sewardj's avatar sewardj
Browse files

[project @ 2000-10-26 14:34:57 by sewardj]

Make HscMain compile.  Hurrah!
parent 11b6abfb
......@@ -4,7 +4,7 @@
\section[CmSummarise]{Module summariser for GHCI}
\begin{code}
module CmSummarise ( ModImport(..), mi_name,
module CmSummarise ( ModImport(..), mimp_name,
ModSummary(..), summarise, ms_get_imports,
name_of_summary, deps_of_summary,
getImports )
......@@ -62,14 +62,14 @@ instance Outputable ModImport where
ppr (MISource nm) = text "{-# SOURCE #-}" <+> ppr nm
mi_name (MINormal nm) = nm
mi_name (MISource nm) = nm
mimp_name (MINormal nm) = nm
mimp_name (MISource nm) = nm
name_of_summary :: ModSummary -> ModuleName
name_of_summary = moduleName . ms_mod
deps_of_summary :: ModSummary -> [ModuleName]
deps_of_summary = map mi_name . ms_get_imports
deps_of_summary = map mimp_name . ms_get_imports
ms_get_imports :: ModSummary -> [ModImport]
ms_get_imports summ
......
......@@ -137,6 +137,8 @@ cmLoadModule cmstate1 modname
-- then generate version 2's by removing from HIT,HST,UI any
-- modules in the old MG which are not in the new one.
-- TODO: call newFinder to reestablish home module cache?!
putStr "cmLoadModule: downsweep begins\n"
mg2unsorted <- downsweep modname finderr
putStrLn (showSDoc (vcat (map ppr mg2unsorted)))
......
......@@ -277,8 +277,8 @@ data DynFlag
deriving (Eq)
data DynFlags = DynFlags {
coreToDo :: CoreToDo,
stgToDo :: StgToDo,
coreToDo :: [CoreToDo],
stgToDo :: [StgToDo],
hscLang :: HscLang,
hscOutName :: String, -- name of the file in which to place output
flags :: [DynFlag]
......@@ -287,10 +287,10 @@ data DynFlags = DynFlags {
dopt :: DynFlag -> DynFlags -> Bool
dopt f dflags = f `elem` (flags dflags)
dopt_CoreToDo :: DynFlags -> CoreToDo
dopt_CoreToDo :: DynFlags -> [CoreToDo]
dopt_CoreToDo = coreToDo
dopt_StgToDo :: DynFlags -> StgToDo
dopt_StgToDo :: DynFlags -> [StgToDo]
dopt_StgToDo = stgToDo
dopt_OutName :: DynFlags -> String
......
......@@ -44,7 +44,8 @@ import CodeGen ( codeGen )
import CodeOutput ( codeOutput )
import Module ( ModuleName, moduleNameUserString,
moduleUserString, moduleName, emptyModuleEnv )
moduleUserString, moduleName, emptyModuleEnv,
extendModuleEnv )
import CmdLineOpts
import ErrUtils ( ghcExit, doIfSet, dumpIfSet_dyn )
import UniqSupply ( mkSplitUniqSupply )
......@@ -54,22 +55,26 @@ import Outputable
import Char ( isSpace )
import StgInterp ( stgToInterpSyn )
import HscStats ( ppSourceStats )
import HscTypes ( ModDetails, ModIface, PersistentCompilerState(..),
import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..),
PersistentRenamerState(..), WhatsImported(..),
HomeSymbolTable, PackageSymbolTable, ImportVersion,
GenAvailInfo(..), RdrAvailInfo, OrigNameEnv(..),
PackageRuleBase, HomeIfaceTable, PackageIfaceTable,
extendTypeEnv )
extendTypeEnv, groupTyThings, TypeEnv, TyThing,
typeEnvClasses, typeEnvTyCons )
import RnMonad ( ExportItem, ParsedIface(..) )
import CmSummarise ( ModSummary(..), name_of_summary, ms_get_imports )
import CmSummarise ( ModSummary(..), name_of_summary, ms_get_imports,
mimp_name )
import Finder ( Finder )
import InterpSyn ( UnlinkedIBind )
import StgInterp ( ItblEnv )
import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM )
import OccName ( OccName, pprOccName )
import Name ( Name, nameModule, emptyNameEnv, nameOccName,
getName, extendNameEnv_C )
getName, extendNameEnv_C, nameEnvElts )
import VarEnv ( emptyVarEnv )
import Module ( Module, mkModuleName, lookupModuleEnvByName )
\end{code}
......@@ -97,17 +102,13 @@ hscMain
-> Finder
-> ModSummary -- summary, including source filename
-> Maybe ModIface -- old interface, if available
-> String -- file in which to put the output (.s, .hc, .java etc.)
-> [CoreToDo]
-> [StgToDo]
-> HomeSymbolTable -- for home module ModDetails
-> HomeIfaceTable
-> PackageIfaceTable
-> PersistentCompilerState -- IN: persistent compiler state
-> IO HscResult
hscMain dflags finder summary maybe_old_iface output_filename
core_cmds stg_cmds hst hit pit pcs
hscMain dflags finder summary maybe_old_iface hst hit pit pcs
= do {
-- ????? source_unchanged :: Bool -- extracted from summary?
let source_unchanged = trace "WARNING: source_unchanged?!" False
......@@ -123,13 +124,12 @@ hscMain dflags finder summary maybe_old_iface output_filename
what_next | recomp_reqd || no_old_iface = hscRecomp
| otherwise = hscNoRecomp
;
what_next dflags finder summary maybe_checked_iface output_filename
core_cmds stg_cmds hst hit pit pcs_ch
what_next dflags finder summary maybe_checked_iface
hst hit pit pcs_ch
}}
hscNoRecomp dflags finder summary maybe_checked_iface output_filename
core_cmds stg_cmds hst hit pit pcs_ch
hscNoRecomp dflags finder summary maybe_checked_iface hst hit pit pcs_ch
= do {
-- we definitely expect to have the old interface available
let old_iface = case maybe_checked_iface of
......@@ -167,8 +167,7 @@ hscNoRecomp dflags finder summary maybe_checked_iface output_filename
}}}}
hscRecomp dflags finder summary maybe_checked_iface output_filename
core_cmds stg_cmds hst hit pit pcs_ch
hscRecomp dflags finder summary maybe_checked_iface hst hit pit pcs_ch
= do {
-- what target are we shooting for?
let toInterp = dopt_HscLang dflags == HscInterpreted
......@@ -204,29 +203,32 @@ hscRecomp dflags finder summary maybe_checked_iface output_filename
-- DESUGAR, SIMPLIFY, TIDY-CORE
-- We grab the the unfoldings at this point.
(tidy_binds, orphan_rules, foreign_stuff)
<- dsThenSimplThenTidy dflags this_mod tc_result core_cmds
<- dsThenSimplThenTidy dflags (pcs_rules pcs_tc) this_mod tc_result hst
;
-- CONVERT TO STG
(stg_binds, oa_tidy_binds, cost_centre_info, top_level_ids)
<- myCoreToStg dflags this_mod tidy_binds stg_cmds
<- myCoreToStg dflags this_mod tidy_binds
;
-- cook up a new ModDetails now we (finally) have all the bits
let new_details = mkModDetails env_tc local_insts tidy_binds
top_level_ids orphan_rules
;
-- and possibly create a new ModIface
let maybe_final_iface
let maybe_final_iface_and_sdoc
= completeIface maybe_checked_iface new_iface new_details
maybe_final_iface
= case maybe_final_iface_and_sdoc of
Just (fif, sdoc) -> Just fif; Nothing -> Nothing
;
-- Write the interface file
writeIface finder maybe_final_iface
;
-- SimonM does this, higher up
-- -- Write the interface file
-- writeIface finder maybe_final_iface
-- ;
-- do the rest of code generation/emission
(maybe_ibinds, maybe_stub_h_filename, maybe_stub_c_filename)
(maybe_stub_h_filename, maybe_stub_c_filename, maybe_ibinds)
<- restOfCodeGeneration dflags toInterp summary
cost_centre_info foreign_stuff tc_env stg_binds oa_tidy_binds
cost_centre_info foreign_stuff env_tc stg_binds oa_tidy_binds
hit (pcs_PIT pcs_tc)
;
-- and the answer is ...
return (HscOK new_details maybe_final_iface
......@@ -270,15 +272,17 @@ myParseModule dflags summary
restOfCodeGeneration dflags toInterp summary cost_centre_info
foreign_stuff tc_env stg_binds oa_tidy_binds
foreign_stuff env_tc stg_binds oa_tidy_binds
hit pit -- these last two for mapping ModNames to Modules
| toInterp
= return (Nothing, Nothing,
Just (stgToInterpSyn stg_binds local_tycons local_classes))
= do (ibinds,itbl_env)
<- stgToInterpSyn (map fst stg_binds) local_tycons local_classes
return (Nothing, Nothing, Just (ibinds,itbl_env))
| otherwise
= do -------------------------- Code generation -------------------------------
show_pass dflags "CodeGen"
-- _scc_ "CodeGen"
abstractC <- codeGen this_mod imported_modules
abstractC <- codeGen dflags this_mod imported_modules
cost_centre_info fe_binders
local_tycons local_classes stg_binds
......@@ -287,39 +291,54 @@ restOfCodeGeneration dflags toInterp summary cost_centre_info
-- _scc_ "CodeOutput"
ncg_uniqs <- mkSplitUniqSupply 'n'
(maybe_stub_h_name, maybe_stub_c_name)
<- codeOutput this_mod local_tycons local_classes
<- codeOutput dflags this_mod local_tycons local_classes
oa_tidy_binds stg_binds
c_code h_code abstractC ncg_uniqs
return (maybe_stub_h_name, maybe_stub_c_name, Nothing)
where
local_tycons = tcEnvTyCons tc_env
local_classes = tcEnvClasses tc_env
local_tycons = typeEnvTyCons env_tc
local_classes = typeEnvClasses env_tc
this_mod = ms_mod summary
imported_modules = ms_get_imports summary
imported_modules = map (mod_name_to_Module.mimp_name)
(ms_get_imports summary)
(fe_binders,h_code,c_code) = foreign_stuff
mod_name_to_Module :: ModuleName -> Module
mod_name_to_Module nm
= let str_mi = case lookupModuleEnvByName hit nm of
Just mi -> mi
Nothing -> case lookupModuleEnvByName pit nm of
Just mi -> mi
Nothing -> barf nm
in mi_module str_mi
barf nm = pprPanic "mod_name_to_Module: no hst or pst mapping for"
(ppr nm)
dsThenSimplThenTidy dflags this_mod tc_result core_cmds
-- make up ds_uniqs here
dsThenSimplThenTidy dflags rule_base this_mod tc_result hst
= do -------------------------- Desugaring ----------------
-- _scc_ "DeSugar"
show_pass dflags "DeSugar"
ds_uniqs <- mkSplitUniqSupply 'd'
(desugared, rules, h_code, c_code, fe_binders)
<- deSugar this_mod ds_uniqs tc_result
<- deSugar dflags this_mod ds_uniqs hst tc_result
-------------------------- Main Core-language transformations ----------------
-- _scc_ "Core2Core"
(simplified, orphan_rules) <- core2core core_cmds desugared rules
show_pass dflags "Core2Core"
(simplified, orphan_rules)
<- core2core dflags rule_base hst desugared rules
-- Do the final tidy-up
show_pass dflags "CoreTidy"
(tidy_binds, tidy_orphan_rules)
<- tidyCorePgm this_mod simplified orphan_rules
<- tidyCorePgm dflags this_mod simplified orphan_rules
return (tidy_binds, tidy_orphan_rules, (fe_binders,h_code,c_code))
myCoreToStg dflags this_mod tidy_binds stg_cmds
myCoreToStg dflags this_mod tidy_binds
= do
c2s_uniqs <- mkSplitUniqSupply 'c'
st_uniqs <- mkSplitUniqSupply 'g'
......@@ -336,7 +355,7 @@ myCoreToStg dflags this_mod tidy_binds stg_cmds
show_pass dflags "Stg2Stg"
-- _scc_ "Stg2Stg"
(stg_binds2, cost_centre_info) <- stg2stg stg_cmds this_mod st_uniqs stg_binds
(stg_binds2, cost_centre_info) <- stg2stg dflags this_mod st_uniqs stg_binds
let final_ids = collectFinalStgBinders (map fst stg_binds2)
return (stg_binds2, occ_anal_tidy_binds, cost_centre_info, final_ids)
......@@ -368,7 +387,9 @@ initPersistentCompilerState
)
initPackageDetails :: PackageSymbolTable
initPackageDetails = extendTypeEnv emptyModuleEnv wiredInThings
initPackageDetails = extendTypeEnv emptyModuleEnv (groupTyThings wiredInThings)
--initPackageDetails = panic "initPackageDetails"
initPersistentRenamerState :: IO PersistentRenamerState
= do ns <- mkSplitUniqSupply 'r'
......@@ -383,16 +404,20 @@ initPersistentRenamerState :: IO PersistentRenamerState
)
initOrigNames :: FiniteMap (ModuleName,OccName) Name
initOrigNames = grab knownKeyNames `plusFM` grab (map getName wiredInThings)
where
grab names = foldl add emptyFM names
add env name = addToFM env (moduleName (nameModule name), nameOccName name) name
initOrigNames
= grab knownKeyNames `plusFM` grab (map getName wiredInThings)
where
grab names = foldl add emptyFM names
add env name
= addToFM env (moduleName (nameModule name), nameOccName name) name
initRules :: PackageRuleBase
initRules = foldl add emptyVarEnv builtinRules
initRules = emptyRuleBase
{- SHOULD BE (ish)
foldl add emptyVarEnv builtinRules
where
add env (name,rule)
= extendNameEnv_C (\rules _ -> rule:rules)
env name [rule]
= extendRuleBase env name rule
-}
\end{code}
......@@ -19,6 +19,7 @@ module HscTypes (
TyThing(..), groupTyThings, isTyClThing,
TypeEnv, extendTypeEnv, lookupTypeEnv,
typeEnvClasses, typeEnvTyCons,
WhetherHasOrphans, ImportVersion, WhatsImported(..),
PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap,
......@@ -46,11 +47,11 @@ import RdrName ( RdrNameEnv, emptyRdrEnv )
import Name ( Name, NameEnv, NamedThing,
emptyNameEnv, unitNameEnv, extendNameEnv, plusNameEnv,
lookupNameEnv, emptyNameEnv, getName, nameModule,
nameSrcLoc )
nameSrcLoc, nameEnvElts )
import NameSet ( NameSet )
import OccName ( OccName )
import Module ( Module, ModuleName, ModuleEnv,
lookupModuleEnv, lookupModuleEnvByName
extendModuleEnv, lookupModuleEnv, lookupModuleEnvByName
)
import Rules ( RuleBase )
import VarSet ( TyVarSet )
......@@ -224,6 +225,10 @@ instance NamedThing TyThing where
getName (AnId id) = getName id
getName (ATyCon tc) = getName tc
getName (AClass cl) = getName cl
typeEnvClasses env = [cl | AClass cl <- nameEnvElts env]
typeEnvTyCons env = [tc | ATyCon tc <- nameEnvElts env]
\end{code}
......@@ -254,7 +259,7 @@ extendTypeEnv tbl things
= foldFM add tbl things
where
add mod type_env tbl
= panic "extendTypeEnv" --extendModuleEnv mod new_details
= extendModuleEnv tbl mod new_details
where
new_details
= case lookupModuleEnv tbl mod of
......
......@@ -11,14 +11,15 @@ module SimplCore ( core2core ) where
import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..),
SwitchResult(..), intSwitchSet,
opt_UsageSPOn,
DynFlags, DynFlag(..), dopt
DynFlags, DynFlag(..), dopt, dopt_CoreToDo
)
import CoreLint ( beginPass, endPass )
import CoreSyn
import CoreFVs ( ruleSomeFreeVars )
import HscTypes ( PackageRuleBase, HomeSymbolTable, ModDetails(..) )
import CSE ( cseProgram )
import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds, extendRuleBaseList, addRuleBaseFVs )
import Rules ( RuleBase, emptyRuleBase, ruleBaseFVs, ruleBaseIds,
extendRuleBaseList, addRuleBaseFVs )
import Module ( moduleEnvElts )
import CoreUnfold
import PprCore ( pprCoreBindings, pprIdCoreRule )
......@@ -54,16 +55,16 @@ import List ( partition )
%************************************************************************
\begin{code}
core2core :: DynFlags
core2core :: DynFlags -- includes spec of what core-to-core passes to do
-> PackageRuleBase -- Rule-base accumulated from imported packages
-> HomeSymbolTable
-> [CoreToDo] -- Spec of what core-to-core passes to do
-> [CoreBind] -- Binds in
-> [IdCoreRule] -- Rules in
-> IO ([CoreBind], [IdCoreRule]) -- binds, local orphan rules out
core2core dflags pkg_rule_base hst core_todos binds rules
core2core dflags pkg_rule_base hst binds rules
= do
let core_todos = dopt_CoreToDo dflags
us <- mkSplitUniqSupply 's'
let (cp_us, ru_us) = splitUniqSupply us
......
......@@ -20,7 +20,7 @@ import SRT ( computeSRTs )
import CmdLineOpts ( DynFlags, DynFlag(..), dopt,
opt_StgDoLetNoEscapes,
StgToDo(..)
StgToDo(..), dopt_StgToDo
)
import Id ( Id )
import Module ( Module, moduleString )
......@@ -31,8 +31,7 @@ import Outputable
\end{code}
\begin{code}
stg2stg :: DynFlags
-> [StgToDo] -- spec of what stg-to-stg passes to do
stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do
-> Module -- module name (profiling only)
-> UniqSupply -- a name supply
-> [StgBinding] -- input...
......@@ -42,7 +41,7 @@ stg2stg :: DynFlags
[CostCentre], -- "extern" cost-centres
[CostCentreStack])) -- pre-defined "singleton" cost centre stacks
stg2stg dflags stg_todos module_name us binds
stg2stg dflags module_name us binds
= case (splitUniqSupply us) of { (us4now, us4later) ->
doIfSet_dyn dflags Opt_D_verbose_stg2stg (printErrs (text "VERBOSE STG-TO-STG:")) >>
......@@ -51,7 +50,7 @@ stg2stg dflags stg_todos module_name us binds
>>= \ (binds', us, ccs) ->
-- Do the main business!
foldl_mn do_stg_pass (binds', us, ccs) stg_todos
foldl_mn do_stg_pass (binds', us, ccs) (dopt_StgToDo dflags)
>>= \ (processed_binds, _, cost_centres) ->
-- Do essential wind-up
......
......@@ -65,7 +65,7 @@ import Name ( Name, OccName, NamedThing(..),
extendNameEnvList, emptyNameEnv
)
import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
import HscTypes ( DFunId )
import HscTypes ( DFunId, TypeEnv )
import Module ( Module )
import InstEnv ( InstEnv, emptyInstEnv )
import HscTypes ( lookupTypeEnv, TyThing(..), GlobalSymbolTable )
......@@ -92,8 +92,8 @@ data TcEnv
tcInsts :: InstEnv, -- All instances (both imported and in this module)
tcGEnv :: NameEnv TyThing, -- The global type environment we've accumulated while
{- TypeEnv -} -- compiling this module:
tcGEnv :: TypeEnv, -- The global type environment we've accumulated while
{- NameEnv TyThing-}-- compiling this module:
-- types and classes (both imported and local)
-- imported Ids
-- (Ids defined in this module are in the local envt)
......
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