From: sewardj Date: Tue, 14 Nov 2000 13:59:44 +0000 (+0000) Subject: [project @ 2000-11-14 13:59:44 by sewardj] X-Git-Tag: Approximately_9120_patches~3347 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=6556dee91f2af4e041da8c7a7edc513cf5f109ab;p=ghc-hetmet.git [project @ 2000-11-14 13:59:44 by sewardj] Only do batch linking if the upsweep succeeds and someone exports Main.main. --- diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index 820a3b9..7551596 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -36,7 +36,9 @@ module BasicTypes( InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch, - EP(..) + EP(..), + + GhciMode(..) ) where #include "HsVersions.h" @@ -202,6 +204,17 @@ isNonRec NonRecursive = True %************************************************************************ %* * +\subsection[Interactive/Batch]{Interactive/Batch flag} +%* * +%************************************************************************ + +\begin{code} +data GhciMode = Batch + | Interactive +\end{code} + +%************************************************************************ +%* * \subsection[Generic]{Generic flag} %* * %************************************************************************ diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index e072564..12b1f7f 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -20,6 +20,7 @@ import Outputable ( SDoc ) import Digraph ( SCC(..), flattenSCC, flattenSCCs ) import Outputable import Panic ( panic ) +import BasicTypes ( GhciMode(..) ) #include "HsVersions.h" \end{code} @@ -100,7 +101,8 @@ emptyPLS = return (PersistentLinkerState {}) -- between CmLink and DriverPipeline. Same deal as with -- CmSummarise.summarise. link :: ([String] -> IO ()) - -> Bool -- was the upsweep completely successful? + -> GhciMode -- interactive or batch + -> Bool -- attempt linking in batch mode? -> PackageConfigInfo -> [SCC Linkable] -> PersistentLinkerState @@ -112,22 +114,31 @@ link :: ([String] -> IO ()) -- For the moment, in the batch linker, we don't bother to -- tell doLink which packages to link -- it just tries all that -- are available. -link doLink upsweep_complete_success pci groups pls1 - | upsweep_complete_success - = do putStrLn "Hello from the Linker!" +-- batch_attempt_linking should only be *looked at* in +-- batch mode. It should only be True if the upsweep was +-- successful and someone exports main, i.e., we have good +-- reason to believe that linking will succeed. +link doLink Batch batch_attempt_linking pci groups pls1 + | batch_attempt_linking + = do putStrLn "LINK(batch): linkables are ..." putStrLn (showSDoc (vcat (map ppLinkableSCC groups))) let o_files = concatMap getOfiles (flattenSCCs groups) doLink o_files - putStrLn "Bye-bye from the Linker!" + -- doLink only returns if it succeeds + putStrLn "LINK(batch): done" return (LinkOK pls1) | otherwise - = do putStrLn "LINKER: upsweep (partially?) failed; not doing batch linking" + = do putStrLn "LINKER(batch): upsweep (partially?) failed OR main not exported;" + putStrLn " -- not doing linking" return (LinkOK pls1) where getOfiles (LP _) = [] getOfiles (LM _ us) = map nameOfObject (filter isObject us) - +link doLink Interactive batch_attempt_linking pci groups pls1 + = do putStrLn "LINKER(interactive): not yet implemented" + return (LinkOK pls1) + ppLinkableSCC :: SCC Linkable -> SDoc ppLinkableSCC = ppr . flattenSCC diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 732e62a..a7d5ef9 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -14,6 +14,7 @@ where import List ( nub ) import Maybe ( catMaybes, maybeToList, fromMaybe ) +import Maybes ( maybeToBool ) import Outputable import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM ) import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs ) @@ -28,13 +29,17 @@ import CmSummarise ( summarise, ModSummary(..), name_of_summary, deps_of_summary, mimp_name, ms_get_imports ) import Module ( ModuleName, moduleName, packageOfModule, - isModuleInThisPackage, PackageName ) + isModuleInThisPackage, PackageName, moduleEnvElts ) import CmStaticInfo ( Package(..), PackageConfigInfo ) import DriverPipeline ( compile, preprocess, doLink, CompResult(..) ) import HscTypes ( HomeSymbolTable, HomeIfaceTable, - PersistentCompilerState ) + PersistentCompilerState, ModDetails(..) ) +import Name ( lookupNameEnv ) +import PrelNames ( mainName ) import HscMain ( initPersistentCompilerState ) import Finder ( findModule, emptyHomeDirCache ) +import BasicTypes ( GhciMode(..) ) +import Util ( unJust ) \end{code} @@ -163,11 +168,13 @@ cmLoadModule cmstate1 modname -- Try and do linking in some form, depending on whether the -- upsweep was completely or only partially successful. + let ghci_mode = Batch -- ToDo: fix! if upsweepOK then do putStrLn "UPSWEEP COMPLETELY SUCCESSFUL" + let someone_exports_main = any exports_main (moduleEnvElts hst3) let mods_to_relink = upwards_closure mg2 (map modname_of_linkable newLis) pkg_linkables <- find_pkg_linkables_for pcii @@ -177,7 +184,8 @@ cmLoadModule cmstate1 modname let sccs_to_relink = group_uis ui3 mg2 mods_to_relink let all_to_relink = map AcyclicSCC pkg_linkables ++ sccs_to_relink - linkresult <- link doLink True pcii all_to_relink pls1 + linkresult <- link doLink ghci_mode someone_exports_main + pcii all_to_relink pls1 case linkresult of LinkErrs _ _ -> panic "cmLoadModule: link failed (1)" @@ -197,7 +205,7 @@ cmLoadModule cmstate1 modname let sccs_to_relink = group_uis ui3 mg2 mods_to_relink let all_to_relink = map AcyclicSCC pkg_linkables ++ sccs_to_relink - linkresult <- link doLink False pcii all_to_relink pls1 + linkresult <- link doLink ghci_mode False pcii all_to_relink pls1 let (hst4, hit4, ui4) = removeFromTopLevelEnvs mods_to_relink (hst3,hit3,ui3) case linkresult of @@ -210,6 +218,9 @@ cmLoadModule cmstate1 modname = CmState { pcms=pcms4, pcs=pcs3, pls=pls4 } return (cmstate4, Just modname) +exports_main :: ModDetails -> Bool +exports_main md + = maybeToBool (lookupNameEnv (md_types md) mainName) -- Given a (home) module graph and a bunch of names of (home) modules -- within that graph, return the names of any packages needed by the