From: sewardj Date: Mon, 20 Nov 2000 17:42:01 +0000 (+0000) Subject: [project @ 2000-11-20 17:42:00 by sewardj] X-Git-Tag: Approximately_9120_patches~3296 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=96cf57e3ca14b3d9e6654a7780ea0b0ea4f5c0e8;p=ghc-hetmet.git [project @ 2000-11-20 17:42:00 by sewardj] Split HscResult into HscFail | HscNoRecomp | HscRecomp, and clean up producers and consumers of such. In particular, if no recompilation happens, the resulting iface is put into the HIT instead of being thrown away. Also (trivial) unify functions *ModuleInThisPackage with *HomeModule. --- diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index ab21f74..0b0825a 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CLabel.lhs,v 1.42 2000/11/13 14:40:38 simonmar Exp $ +% $Id: CLabel.lhs,v 1.43 2000/11/20 17:42:00 sewardj Exp $ % \section[CLabel]{@CLabel@: Information to make C Labels} @@ -85,7 +85,7 @@ import CmdLineOpts ( opt_Static, opt_DoTickyProfiling ) import CStrings ( pp_cSEP ) import DataCon ( ConTag ) import Module ( moduleName, moduleNameFS, - Module, isModuleInThisPackage ) + Module, isHomeModule ) import Name ( Name, getName, isDllName, isExternallyVisibleName ) import TyCon ( TyCon ) import Unique ( pprUnique, Unique ) @@ -387,7 +387,7 @@ labelDynamic lbl = DataConLabel n k -> isDllName n TyConLabel tc -> isDllName (getName tc) ForeignLabel _ d -> d - ModuleInitLabel m -> (not opt_Static) && (not (isModuleInThisPackage m)) + ModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m)) _ -> False \end{code} diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index 5676bc2..7a2aa1b 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -24,7 +24,6 @@ module Module Module, moduleName, packageOfModule, -- abstract, instance of Eq, Ord, Outputable , ModuleName - , isModuleInThisPackage, mkModuleInThisPackage, , printModulePrefix , moduleNameString -- :: ModuleName -> EncodedString @@ -38,8 +37,7 @@ module Module , mkPrelModule -- :: UserString -> Module , mkModule -- :: ModuleName -> PackageName -> Module , mkHomeModule -- :: ModuleName -> Module - --- , mkSrcModule + , isHomeModule -- :: Module -> Bool , mkModuleName -- :: UserString -> ModuleName , mkModuleNameFS -- :: UserFS -> ModuleName @@ -192,10 +190,6 @@ mkModuleNameFS s = ModuleName (encodeFS s) -- used to be called mkSysModuleFS mkSysModuleNameFS :: EncodedFS -> ModuleName mkSysModuleNameFS s = ModuleName s - --- Make a module in this package -mkModuleInThisPackage :: ModuleName -> Module -mkModuleInThisPackage nm = Module nm ThisPackage \end{code} \begin{code} @@ -241,6 +235,10 @@ mkModule mod_nm pack_name mkHomeModule :: ModuleName -> Module mkHomeModule mod_nm = Module mod_nm ThisPackage +isHomeModule :: Module -> Bool +isHomeModule (Module nm ThisPackage) = True +isHomeModule _ = False + -- Used temporarily when we first come across Foo.x in an interface -- file, but before we've opened Foo.hi. -- (Until we've opened Foo.hi we don't know what the PackageInfo is.) @@ -259,10 +257,6 @@ moduleName (Module mod pkg_info) = mod moduleUserString :: Module -> UserString moduleUserString (Module mod _) = moduleNameUserString mod -isModuleInThisPackage :: Module -> Bool -isModuleInThisPackage (Module nm ThisPackage) = True -isModuleInThisPackage _ = False - packageOfModule :: Module -> Maybe PackageName packageOfModule (Module nm (AnotherPackage pn)) = Just pn packageOfModule _ = Nothing diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 1a0e155..2e66f08 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -42,7 +42,7 @@ module Name ( #include "HsVersions.h" import OccName -- All of it -import Module ( Module, moduleName, mkVanillaModule, isModuleInThisPackage ) +import Module ( Module, moduleName, mkVanillaModule, isHomeModule ) import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule ) import CmdLineOpts ( opt_Static, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc ) @@ -334,7 +334,7 @@ isDllName :: Name -> Bool -- Does this name refer to something in a different DLL? isDllName nm = not opt_Static && not (isLocalName nm) && -- isLocalName test needed 'cos - not (isModuleInThisPackage (nameModule nm)) -- nameModule won't work on local names + not (isHomeModule (nameModule nm)) -- nameModule won't work on local names diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 7f0885a..3b53564 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -18,7 +18,7 @@ import CmLink import CmTypes import HscTypes import Module ( ModuleName, moduleName, - isModuleInThisPackage, moduleEnvElts, + isHomeModule, moduleEnvElts, moduleNameUserString ) import CmStaticInfo ( PackageConfigInfo, GhciMode(..) ) import DriverPipeline @@ -73,7 +73,7 @@ cmGetExpr :: CmState -> IO (CmState, Maybe HValue) cmGetExpr cmstate dflags modname expr = do (new_pcs, maybe_unlinked_iexpr) <- - hscExpr dflags hst hit pcs (mkModuleInThisPackage modname) expr + hscExpr dflags hst hit pcs (mkHomeModule modname) expr case maybe_unlinked_iexpr of Nothing -> return (cmstate{ pcs=new_pcs }, Nothing) Just uiexpr -> do @@ -440,19 +440,19 @@ upsweep_mod ghci_mode oldUI threaded1 summary1 reachable_from_here case compresult of - -- Compilation "succeeded", but didn't return a new iface or + -- Compilation "succeeded", but didn't return a new -- linkable, meaning that compilation wasn't needed, and the -- new details were manufactured from the old iface. - CompOK details Nothing pcs2 - -> let hst2 = addToUFM hst1 mod_name details - hit2 = hit1 + CompOK pcs2 new_details new_iface Nothing + -> let hst2 = addToUFM hst1 mod_name new_details + hit2 = addToUFM hit1 mod_name new_iface threaded2 = CmThreaded pcs2 hst2 hit2 in return (threaded2, Just old_linkable) -- Compilation really did happen, and succeeded. A new -- details, iface and linkable are returned. - CompOK details (Just (new_iface, new_linkable)) pcs2 - -> let hst2 = addToUFM hst1 mod_name details + CompOK pcs2 new_details new_iface (Just new_linkable) + -> let hst2 = addToUFM hst1 mod_name new_details hit2 = addToUFM hit1 mod_name new_iface threaded2 = CmThreaded pcs2 hst2 hit2 in return (threaded2, Just new_linkable) @@ -545,7 +545,7 @@ topological_sort include_source_imports summaries downsweep :: [FilePath] -> IO [ModSummary] downsweep rootNm = do rootSummaries <- mapM getRootSummary rootNm - loop (filter (isModuleInThisPackage.ms_mod) rootSummaries) + loop (filter (isHomeModule.ms_mod) rootSummaries) where getRootSummary :: FilePath -> IO ModSummary getRootSummary file @@ -584,7 +584,7 @@ downsweep rootNm neededSummaries <- mapM getSummary neededImps let newHomeSummaries - = filter (isModuleInThisPackage.ms_mod) neededSummaries + = filter (isHomeModule.ms_mod) neededSummaries if null newHomeSummaries then return homeSummaries else loop (newHomeSummaries ++ homeSummaries) @@ -627,7 +627,7 @@ summariseFile file -- Summarise a module, and pick up source and interface timestamps. summarise :: Module -> ModuleLocation -> IO ModSummary summarise mod location - | isModuleInThisPackage mod + | isHomeModule mod = do let hs_fn = unJust "summarise" (ml_hs_file location) hspp_fn <- preprocess hs_fn modsrc <- readFile hspp_fn diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 1d75248..1e7adfe 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPipeline.hs,v 1.32 2000/11/20 13:39:26 sewardj Exp $ +-- $Id: DriverPipeline.hs,v 1.33 2000/11/20 17:42:00 sewardj Exp $ -- -- GHC Driver -- @@ -467,8 +467,10 @@ run_phase Hsc basename suff input_fn output_fn HscFail pcs -> throwDyn (PhaseFailed "hsc" (ExitFailure 1)); - HscOK details maybe_iface maybe_stub_h maybe_stub_c - _maybe_interpreted_code pcs -> do + HscNoRecomp pcs details iface -> return False; + + HscRecomp pcs details iface maybe_stub_h maybe_stub_c + _maybe_interpreted_code -> do -- deal with stubs maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c @@ -476,8 +478,7 @@ run_phase Hsc basename suff input_fn output_fn Nothing -> return () Just stub_o -> add v_Ld_inputs stub_o - let keep_going = case maybe_iface of Just _ -> True; Nothing -> False - return keep_going + return True } ----------------------------------------------------------------------------- @@ -758,11 +759,12 @@ compile :: GhciMode -- distinguish batch from interactive -> IO CompResult data CompResult - = CompOK ModDetails -- new details (HST additions) - (Maybe (ModIface, Linkable)) - -- summary and code; Nothing => compilation not reqd - -- (old summary and code are still valid) - PersistentCompilerState -- updated PCS + = CompOK PersistentCompilerState -- updated PCS + ModDetails -- new details (HST additions) + ModIface -- new iface (HIT additions) + (Maybe Linkable) + -- new code; Nothing => compilation was not reqd + -- (old code is still valid) | CompErrs PersistentCompilerState -- updated PCS @@ -800,17 +802,14 @@ compile ghci_mode summary source_unchanged old_iface hst hit pcs = do source_unchanged location old_iface hst hit pcs - case hsc_result of { - HscFail pcs -> return (CompErrs pcs); + case hsc_result of + HscFail pcs -> return (CompErrs pcs) - HscOK details maybe_iface - maybe_stub_h maybe_stub_c maybe_interpreted_code pcs -> do - - -- if no compilation happened, bail out early - case maybe_iface of { - Nothing -> return (CompOK details Nothing pcs); - Just iface -> do + HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing) + HscRecomp pcs details iface + maybe_stub_h maybe_stub_c maybe_interpreted_code -> do + let (basename, _) = splitFilename input_fn maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c let stub_unlinked = case maybe_stub_o of @@ -843,9 +842,8 @@ compile ghci_mode summary source_unchanged old_iface hst hit pcs = do let linkable = LM unlinked_time (moduleName (ms_mod summary)) (hs_unlinked ++ stub_unlinked) - return (CompOK details (Just (iface, linkable)) pcs) - } - } + return (CompOK pcs details iface (Just linkable)) + ----------------------------------------------------------------------------- -- stub .h and .c files (for foreign export support) diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index a21fce4..9ea640b 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -40,7 +40,7 @@ import SimplStg ( stg2stg ) import CodeGen ( codeGen ) import CodeOutput ( codeOutput ) -import Module ( ModuleName, moduleName, mkModuleInThisPackage ) +import Module ( ModuleName, moduleName, mkHomeModule ) import CmdLineOpts import ErrUtils ( dumpIfSet_dyn, showPass ) import Util ( unJust ) @@ -76,14 +76,21 @@ import IO ( hPutStrLn, stderr ) \begin{code} data HscResult - = HscOK ModDetails -- new details (HomeSymbolTable additions) - (Maybe ModIface) -- new iface (if any compilation was done) - (Maybe String) -- generated stub_h filename (in /tmp) - (Maybe String) -- generated stub_c filename (in /tmp) - (Maybe ([UnlinkedIBind],ItblEnv)) -- interpreted code, if any - PersistentCompilerState -- updated PCS - - | HscFail PersistentCompilerState -- updated PCS + -- compilation failed + = HscFail PersistentCompilerState -- updated PCS + -- concluded that it wasn't necessary + | HscNoRecomp PersistentCompilerState -- updated PCS + ModDetails -- new details (HomeSymbolTable additions) + ModIface -- new iface (if any compilation was done) + -- did recompilation + | HscRecomp PersistentCompilerState -- updated PCS + ModDetails -- new details (HomeSymbolTable additions) + ModIface -- new iface (if any compilation was done) + (Maybe String) -- generated stub_h filename (in /tmp) + (Maybe String) -- generated stub_c filename (in /tmp) + (Maybe ([UnlinkedIBind],ItblEnv)) -- interpreted code, if any + + -- no errors or warnings; the individual passes -- (parse/rename/typecheck) print messages themselves @@ -125,12 +132,8 @@ hscMain ghci_mode dflags source_unchanged location maybe_old_iface hst hit pcs -- we definitely expect to have the old interface available hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch | ghci_mode == OneShot - = return (HscOK - (panic "hscNoRecomp:OneShot") -- no details - Nothing -- makes run_phase Hsc stop - Nothing Nothing -- foreign export stuff - Nothing -- ibinds - pcs_ch) + = let bomb = panic "hscNoRecomp:OneShot" + in return (HscNoRecomp pcs_ch bomb bomb) | otherwise = do { hPutStrLn stderr "COMPILATION NOT REQUIRED"; @@ -156,11 +159,7 @@ hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch -- create a new details from the closed, typechecked, old iface let new_details = mkModDetailsFromIface env_tc local_insts local_rules ; - return (HscOK new_details - Nothing -- tells CM to use old iface and linkables - Nothing Nothing -- foreign export stuff - Nothing -- ibinds - pcs_tc) + return (HscNoRecomp pcs_tc new_details old_iface) }}}} @@ -179,7 +178,7 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch ; case maybe_parsed of { Nothing -> return (HscFail pcs_ch); Just rdr_module -> do { - ; let this_mod = mkModuleInThisPackage (hsModuleName rdr_module) + ; let this_mod = mkHomeModule (hsModuleName rdr_module) ------------------- -- RENAME @@ -238,9 +237,9 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch hit (pcs_PIT pcs_tc) -- and the answer is ... - ; return (HscOK new_details (Just final_iface) - maybe_stub_h_filename maybe_stub_c_filename - maybe_ibinds pcs_tc) + ; return (HscRecomp pcs_tc new_details final_iface + maybe_stub_h_filename maybe_stub_c_filename + maybe_ibinds) }}}}}}} diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 4c3b864..29a6449 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -44,7 +44,7 @@ import Name ( Name {-instance NamedThing-}, nameOccName, ) import Name ( mkNameEnv, extendNameEnv ) import Module ( Module, - moduleName, isModuleInThisPackage, + moduleName, isHomeModule, ModuleName, WhereFrom(..), extendModuleEnv, mkVanillaModule ) @@ -176,7 +176,7 @@ tryLoadInterface doc_str mod_name from -- about, it should be from a different package to this one WARN( not (maybeToBool mod_info) && case from of { ImportBySystem -> True; other -> False } && - isModuleInThisPackage mod, + isHomeModule mod, ppr mod ) loadDecls mod (iDecls ifaces) (pi_decls iface) `thenRn` \ (decls_vers, new_decls) -> @@ -241,7 +241,7 @@ addModDeps mod is_loaded new_deps mod_deps -- and in that case, forget about the boot indicator filtered_new_deps :: [(ModuleName, (WhetherHasOrphans, IsBootInterface))] filtered_new_deps - | isModuleInThisPackage mod + | isHomeModule mod = [ (imp_mod, (has_orphans, is_boot)) | (imp_mod, has_orphans, is_boot, _) <- new_deps, not (is_loaded imp_mod) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 7311439..d1e4174 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -44,7 +44,7 @@ import Name ( Name {-instance NamedThing-}, nameOccName, ) import Name ( elemNameEnv, delFromNameEnv ) import Module ( Module, ModuleEnv, - moduleName, isModuleInThisPackage, + moduleName, isHomeModule, ModuleName, WhereFrom(..), emptyModuleEnv, extendModuleEnv_C, foldModuleEnv, lookupModuleEnv, @@ -178,7 +178,7 @@ mkImportInfo this_mod imports mod = mi_module iface mod_name = moduleName mod - is_home_pkg_mod = isModuleInThisPackage mod + is_home_pkg_mod = isHomeModule mod version_info = mi_version iface version_env = vers_decls version_info mod_vers = vers_module version_info @@ -341,8 +341,8 @@ recordSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped), main_name = availName avail mod = nameModule main_name new_slurped_names = addAvailToNameSet slurped_names avail - new_vslurp | isModuleInThisPackage mod = (imp_mods, addOneToNameSet imp_names main_name) - | otherwise = (extendModuleSet imp_mods mod, imp_names) + new_vslurp | isHomeModule mod = (imp_mods, addOneToNameSet imp_names main_name) + | otherwise = (extendModuleSet imp_mods mod, imp_names) recordLocalSlurps new_names = getIfacesRn `thenRn` \ ifaces ->