From d893f3809b61eca1b7a45f3eb63d39b25f757c40 Mon Sep 17 00:00:00 2001 From: sewardj Date: Thu, 26 Oct 2000 14:34:58 +0000 Subject: [PATCH] [project @ 2000-10-26 14:34:57 by sewardj] Make HscMain compile. Hurrah! --- ghc/compiler/ghci/CmSummarise.lhs | 8 +-- ghc/compiler/ghci/CompManager.lhs | 2 + ghc/compiler/main/CmdLineOpts.lhs | 8 +-- ghc/compiler/main/HscMain.lhs | 123 ++++++++++++++++++++-------------- ghc/compiler/main/HscTypes.lhs | 11 ++- ghc/compiler/simplCore/SimplCore.lhs | 11 +-- ghc/compiler/simplStg/SimplStg.lhs | 9 ++- ghc/compiler/typecheck/TcEnv.lhs | 6 +- 8 files changed, 105 insertions(+), 73 deletions(-) diff --git a/ghc/compiler/ghci/CmSummarise.lhs b/ghc/compiler/ghci/CmSummarise.lhs index f68ca48..19bfb37 100644 --- a/ghc/compiler/ghci/CmSummarise.lhs +++ b/ghc/compiler/ghci/CmSummarise.lhs @@ -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 diff --git a/ghc/compiler/ghci/CompManager.lhs b/ghc/compiler/ghci/CompManager.lhs index 0c4998d..dc03339 100644 --- a/ghc/compiler/ghci/CompManager.lhs +++ b/ghc/compiler/ghci/CompManager.lhs @@ -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))) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index f9a7373..ab25539 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -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 diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 013ea6a..4d8a9e8 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -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} diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 9550ac6..de1c5aa 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -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 diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 723b776..15257e7 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -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 diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index a06915c..7fd03ea 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -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 diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 5c73d8a..bbb8573 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -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) -- 1.7.10.4