From f212eb91f4286baf6d67f95b37e61ddd0c5e06e1 Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 16 Nov 2000 15:57:06 +0000 Subject: [PATCH] [project @ 2000-11-16 15:57:05 by simonmar] Moving things around a bit to avoid cycles. Further progress on interactive linker. --- ghc/compiler/compMan/CmLink.lhs | 179 ++++++++++++++++++---------------- ghc/compiler/compMan/CmSummarise.lhs | 175 --------------------------------- ghc/compiler/compMan/CmTypes.lhs | 80 +++++++++++++++ ghc/compiler/compMan/CompManager.lhs | 50 +++++++--- ghc/compiler/ghci/StgInterp.lhs | 31 +++--- ghc/compiler/main/DriverPipeline.hs | 6 +- ghc/compiler/main/GetImports.hs | 85 ++++++++++++++++ ghc/compiler/main/HscMain.lhs | 5 +- ghc/compiler/main/Interpreter.hs | 4 +- ghc/compiler/main/Main.hs | 11 ++- 10 files changed, 328 insertions(+), 298 deletions(-) delete mode 100644 ghc/compiler/compMan/CmSummarise.lhs create mode 100644 ghc/compiler/compMan/CmTypes.lhs create mode 100644 ghc/compiler/main/GetImports.hs diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index 811601b..0e46c88 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -10,19 +10,26 @@ module CmLink ( Linkable(..), Unlinked(..), modname_of_linkable, is_package_linkable, LinkResult(..), link, - PersistentLinkerState{-abstractly!-}, emptyPLS ) -where + unload, + PersistentLinkerState{-abstractly!-}, emptyPLS + ) where import Interpreter -import CmStaticInfo ( PackageConfigInfo, GhciMode(..) ) +import DriverPipeline +import CmTypes +import CmStaticInfo ( GhciMode(..) ) import Module ( ModuleName, PackageName ) import Outputable ( SDoc ) import FiniteMap import Digraph ( SCC(..), flattenSCC ) import Outputable +import Exception +import DriverUtil import Panic ( panic ) +import IO + #include "HsVersions.h" \end{code} @@ -53,40 +60,6 @@ data LinkResult = LinkOK PersistentLinkerState | LinkErrs PersistentLinkerState [SDoc] -data Unlinked - = DotO FilePath - | DotA FilePath - | DotDLL FilePath - | Trees [UnlinkedIBind] ItblEnv -- bunch of interpretable bindings, + - -- a mapping from DataCons to their itbls - -instance Outputable Unlinked where - ppr (DotO path) = text "DotO" <+> text path - ppr (DotA path) = text "DotA" <+> text path - ppr (DotDLL path) = text "DotDLL" <+> text path - ppr (Trees binds _) = text "Trees" <+> ppr binds - - -isObject (DotO _) = True -isObject (DotA _) = True -isObject (DotDLL _) = True -isObject _ = False - -nameOfObject (DotO fn) = fn -nameOfObject (DotA fn) = fn -nameOfObject (DotDLL fn) = fn - -isInterpretable (Trees _ _) = True -isInterpretable _ = False - -data Linkable - = LM ModuleName [Unlinked] - | LP PackageName - -instance Outputable Linkable where - ppr (LM mod_nm unlinkeds) = text "LinkableM" <+> ppr mod_nm <+> ppr unlinkeds - ppr (LP package_nm) = text "LinkableP" <+> ptext package_nm - findModuleLinkable :: [Linkable] -> ModuleName -> Linkable findModuleLinkable lis mod = case [LM nm us | LM nm us <- lis, nm == mod] of @@ -104,74 +77,54 @@ emptyPLS = return (PersistentLinkerState {}) \end{code} \begin{code} --- The first arg is supposed to be DriverPipeline.doLink. --- Passed in here to avoid a hard-to-avoid circular dependency --- between CmLink and DriverPipeline. Same deal as with --- CmSummarise.summarise. -link :: ([String] -> IO ()) - -> GhciMode -- interactive or batch +link :: GhciMode -- interactive or batch -> Bool -- attempt linking in batch mode? -> [Linkable] -- only contains LMs, not LPs -> PersistentLinkerState -> IO LinkResult -#ifndef GHCI_NOTYET ---link = panic "CmLink.link: not implemented" - --- 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. --- 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 linkables pls1 +-- 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. +-- 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. + +-- There will be (ToDo: are) two lists passed to link. These +-- correspond to +-- +-- 1. The list of all linkables in the current home package. This is +-- used by the batch linker to link the program, and by the interactive +-- linker to decide which modules from the previous link it can +-- throw away. +-- 2. The list of modules on which we just called "compile". This list +-- is used by the interactive linker to decide which modules need +-- to be actually linked this time around (or unlinked and re-linked +-- if the module was recompiled). + +link Batch batch_attempt_linking linkables pls1 | batch_attempt_linking - = do putStrLn "LINK(batch): linkables are ..." - putStrLn (showSDoc (vcat (map ppr linkables))) + = do hPutStrLn stderr "CmLink.link(batch): linkables are ..." + hPutStrLn stderr (showSDoc (vcat (map ppr linkables))) let o_files = concatMap getOfiles linkables doLink o_files -- doLink only returns if it succeeds - putStrLn "LINK(batch): done" + hPutStrLn stderr "CmLink.link(batch): done" return (LinkOK pls1) | otherwise - = do putStrLn "LINKER(batch): upsweep (partially?) failed OR main not exported;" - putStrLn " -- not doing linking" + = do hPutStrLn stderr "CmLink.link(batch): upsweep (partially?) failed OR main not exported;" + hPutStrLn stderr " -- not doing linking" return (LinkOK pls1) where - getOfiles (LP _) = panic "link.getOfiles: shouldn't get package linkables" + getOfiles (LP _) = panic "CmLink.link(getOfiles): shouldn't get package linkables" getOfiles (LM _ us) = map nameOfObject (filter isObject us) -link doLink Interactive batch_attempt_linking linkables pls1 - = do putStrLn "LINKER(interactive): not yet implemented" - return (LinkOK pls1) +link Interactive batch_attempt_linking linkables pls1 + = linkObjs linkables pls1 ppLinkableSCC :: SCC Linkable -> SDoc ppLinkableSCC = ppr . flattenSCC -#else - - -link pci [] pls = return (LinkOK pls) -link pci (groupSCC:groups) pls = do - let group = flattenSCC groupSCC - -- the group is either all objects or all interpretable, for now - if all isObject group - then do mapM loadObj [ file | DotO file <- group ] - resolveObjs - link pci groups pls - else if all isInterpretable group - then do (new_closure_env, new_itbl_env) <- - linkIModules (closure_env pls) - (itbl_env pls) - [ trees | Trees trees <- group ] - link pci groups (PersistentLinkerState{ - closure_env=new_closure_env, - itbl_env=new_itbl_env}) - else - return (LinkErrs pls (ptext SLIT("linker: group must contain all objects or all interpreted modules"))) -#endif - modname_of_linkable (LM nm _) = nm modname_of_linkable (LP _) = panic "modname_of_linkable: package" @@ -190,4 +143,58 @@ filterModuleLinkables p (li:lis) where dump = filterModuleLinkables p lis retain = li : dump + +----------------------------------------------------------------------------- +-- Linker for interactive mode + +#ifndef GHCI +linkObjs = panic "CmLink.linkObjs: no interpreter" +#else +linkObjs [] pls = linkFinish pls [] [] +linkObjs (l@(LM _ uls) : ls) pls + | all isObject uls = do + mapM_ loadObj [ file | DotO file <- uls ] + linkObjs ls pls + | all isInterpretable uls = linkInterpretedCode (l:ls) [] [] pls + | otherwise = invalidLinkable +linkObjs _ pls = + throwDyn (OtherError "CmLink.linkObjs: found package linkable") + + +linkInterpretedCode [] mods ul_trees pls = linkFinish pls mods ul_trees +linkInterpretedCode (LM m uls : ls) mods ul_trees pls + | all isInterpretable uls = + linkInterpretedCode ls (m:mods) (uls++ul_trees) pls + + | any isObject uls + = throwDyn (OtherError "can't link object code that depends on interpreted code") + | otherwise = invalidLinkable +linkInterpretedCode _ _ _ pls = + throwDyn (OtherError "CmLink.linkInterpretedCode: found package linkable") + +invalidLinkable = throwDyn (OtherError "linkable doesn't contain entirely objects interpreted code") + + +-- link all the interpreted code in one go. We first remove from the +-- various environments any previous versions of these modules. +linkFinish pls mods ul_trees = do + let itbl_env' = filterRdrNameEnv mods (itbl_env pls) + closure_env' = filterRdrNameEnv mods (closure_env pls) + stuff = [ (trees,itbls) | Trees trees itbls <- ul_trees ] + + (ibinds, new_itbl_env, new_closure_env) <- + linkIModules closure_env' itbl_env' stuff + + let new_pls = PersistentLinkerState { + closure_env = new_closure_env, + itbl_env = new_itbl_env + } + resolveObjs + return (LinkOK new_pls) + +-- purge the current "linked image" +unload :: PersistentLinkerState -> IO PersistentLinkerState +unload pls = return pls{ closure_env = emptyFM, itbl_env = emptyFM } + +#endif \end{code} diff --git a/ghc/compiler/compMan/CmSummarise.lhs b/ghc/compiler/compMan/CmSummarise.lhs deleted file mode 100644 index e1b7b27..0000000 --- a/ghc/compiler/compMan/CmSummarise.lhs +++ /dev/null @@ -1,175 +0,0 @@ -% -% (c) The University of Glasgow, 2000 -% -\section[CmSummarise]{Module summariser for GHCI} - -\begin{code} -module CmSummarise ( ModSummary(..), summarise, name_of_summary, - getImports {-, source_has_changed-} ) -where - -#include "HsVersions.h" - -import List ( nub ) -import Char ( isAlphaNum ) ---import Time ( ClockTime ) ---import Directory ( getModificationTime ) - -import Util ( unJust ) -import HscTypes ( ModuleLocation(..) ) -import Module -import Outputable -\end{code} - -\begin{code} - - --- The ModuleLocation contains both the original source filename and the --- filename of the cleaned-up source file after all preprocessing has been --- done. The point is that the summariser will have to cpp/unlit/whatever --- all files anyway, and there's no point in doing this twice -- just --- park the result in a temp file, put the name of it in the location, --- and let @compile@ read from that file on the way back up. -data ModSummary - = ModSummary { - ms_mod :: Module, -- name, package - ms_location :: ModuleLocation, -- location - ms_srcimps :: [ModuleName], -- source imports - ms_imps :: [ModuleName] -- non-source imports - --ms_date :: Maybe ClockTime -- timestamp of summarised - -- file, if home && source - } - -instance Outputable ModSummary where - ppr ms - = sep [--text "ModSummary { ms_date = " <> text (show ms_date), - text "ModSummary {", - nest 3 (sep [text "ms_mod =" <+> ppr (ms_mod ms) <> comma, - text "ms_imps =" <+> ppr (ms_imps ms), - text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), - char '}' - ] - -name_of_summary :: ModSummary -> ModuleName -name_of_summary = moduleName . ms_mod - - --- The first arg is supposed to be DriverPipeline.preprocess. --- Passed in here to avoid a hard-to-avoid circular dependency --- between CmSummarise and DriverPipeline. Same deal as with --- CmLink.link. -summarise :: (FilePath -> IO FilePath) - -> Module -> ModuleLocation -> IO ModSummary -summarise preprocess mod location - | isModuleInThisPackage mod - = do let hs_fn = unJust (ml_hs_file location) "summarise" - hspp_fn <- preprocess hs_fn - modsrc <- readFile hspp_fn - let (srcimps,imps) = getImports modsrc - --- maybe_timestamp --- <- case ml_hs_file location of --- Nothing -> return Nothing --- Just src_fn -> getModificationTime src_fn >>= Just - - return (ModSummary mod location{ml_hspp_file=Just hspp_fn} - srcimps imps - {-maybe_timestamp-} ) - | otherwise - = return (ModSummary mod location [] []) - --- Compare the timestamp on the source file with that already --- in the summary, and see if the source file is younger. If --- in any doubt, return True (because False could cause compilation --- to be omitted). -{- -source_has_changed :: ModSummary -> IO Bool -source_has_changed summary - = case ms_date summary of { - Nothing -> True; -- don't appear to have a previous timestamp - Just summ_date -> - case ml_hs_file (ms_loc summary) of { - Nothing -> True; -- don't appear to have a source file (?!?!) - Just src_fn -> do now_date <- getModificationTime src_fn - return (now_date > summ_date) - }} --} -\end{code} - -Collect up the imports from a Haskell source module. This is -approximate: we don't parse the module, but we do eliminate comments -and strings. Doesn't currently know how to unlit or cppify the module -first. - -\begin{code} -getImports :: String -> ([ModuleName], [ModuleName]) -getImports str - = let all_imps = (nub . gmiBase . clean) str - srcs = concatMap (either unit nil) all_imps - normals = concatMap (either nil unit) all_imps - unit x = [x] - nil x = [] - in (srcs, normals) - --- really get the imports from a de-litted, cpp'd, de-literal'd string --- Lefts are source imports. Rights are normal ones. -gmiBase :: String -> [Either ModuleName ModuleName] -gmiBase s - = f (words s) - where - f ("foreign" : "import" : ws) = f ws - f ("import" : "{-#" : "SOURCE" : "#-}" : "qualified" : m : ws) - = Left (mkMN m) : f ws - f ("import" : "{-#" : "SOURCE" : "#-}" : m : ws) - = Left (mkMN m) : f ws - f ("import" : "qualified" : m : ws) - = Right (mkMN m) : f ws - f ("import" : m : ws) - = Right (mkMN m) : f ws - f (w:ws) = f ws - f [] = [] - - mkMN str = mkModuleName (takeWhile isModId str) - isModId c = isAlphaNum c || c `elem` "'_" - --- remove literals and comments from a string -clean :: String -> String -clean s - = keep s - where - -- running through text we want to keep - keep [] = [] - keep ('"':cs) = dquote cs -- " - -- try to eliminate single quotes when they're part of - -- an identifier... - keep (c:'\'':cs) | isAlphaNum c || c == '_' = keep (dropWhile (=='\'') cs) - keep ('\'':cs) = squote cs - keep ('-':'-':cs) = linecomment cs - keep ('{':'-':'#':' ':cs) = "{-# " ++ keep cs - keep ('{':'-':cs) = runcomment cs -- -} - keep (c:cs) = c : keep cs - - -- in a double-quoted string - dquote [] = [] - dquote ('\\':'\"':cs) = dquote cs -- " - dquote ('\\':'\\':cs) = dquote cs - dquote ('\"':cs) = keep cs -- " - dquote (c:cs) = dquote cs - - -- in a single-quoted string - squote [] = [] - squote ('\\':'\'':cs) = squote cs - squote ('\\':'\\':cs) = squote cs - squote ('\'':cs) = keep cs - squote (c:cs) = squote cs - - -- in a line comment - linecomment [] = [] - linecomment ('\n':cs) = '\n':keep cs - linecomment (c:cs) = linecomment cs - - -- in a running comment - runcomment [] = [] - runcomment ('-':'}':cs) = keep cs - runcomment (c:cs) = runcomment cs -\end{code} diff --git a/ghc/compiler/compMan/CmTypes.lhs b/ghc/compiler/compMan/CmTypes.lhs new file mode 100644 index 0000000..a57ef9e --- /dev/null +++ b/ghc/compiler/compMan/CmTypes.lhs @@ -0,0 +1,80 @@ +% +% (c) The University of Glasgow, 2000 +% +\section[CmTypes]{Types for the compilation manager} + +\begin{code} +module CmTypes ( + Unlinked(..), isObject, nameOfObject, isInterpretable, + Linkable(..), + ModSummary(..), name_of_summary + ) where + +import Interpreter +import HscTypes +import Module +import CmStaticInfo +import Outputable + +data Unlinked + = DotO FilePath + | DotA FilePath + | DotDLL FilePath + | Trees [UnlinkedIBind] ItblEnv -- bunch of interpretable bindings, + + -- a mapping from DataCons to their itbls + +instance Outputable Unlinked where + ppr (DotO path) = text "DotO" <+> text path + ppr (DotA path) = text "DotA" <+> text path + ppr (DotDLL path) = text "DotDLL" <+> text path + ppr (Trees binds _) = text "Trees" <+> ppr binds + +isObject (DotO _) = True +isObject (DotA _) = True +isObject (DotDLL _) = True +isObject _ = False + +nameOfObject (DotO fn) = fn +nameOfObject (DotA fn) = fn +nameOfObject (DotDLL fn) = fn + +isInterpretable (Trees _ _) = True +isInterpretable _ = False + +data Linkable + = LM ModuleName [Unlinked] + | LP PackageName + +instance Outputable Linkable where + ppr (LM mod_nm unlinkeds) = text "LinkableM" <+> ppr mod_nm <+> ppr unlinkeds + ppr (LP package_nm) = text "LinkableP" <+> ptext package_nm + +-- The ModuleLocation contains both the original source filename and the +-- filename of the cleaned-up source file after all preprocessing has been +-- done. The point is that the summariser will have to cpp/unlit/whatever +-- all files anyway, and there's no point in doing this twice -- just +-- park the result in a temp file, put the name of it in the location, +-- and let @compile@ read from that file on the way back up. +data ModSummary + = ModSummary { + ms_mod :: Module, -- name, package + ms_location :: ModuleLocation, -- location + ms_srcimps :: [ModuleName], -- source imports + ms_imps :: [ModuleName] -- non-source imports + --ms_date :: Maybe ClockTime -- timestamp of summarised + -- file, if home && source + } + +instance Outputable ModSummary where + ppr ms + = sep [--text "ModSummary { ms_date = " <> text (show ms_date), + text "ModSummary {", + nest 3 (sep [text "ms_mod =" <+> ppr (ms_mod ms) <> comma, + text "ms_imps =" <+> ppr (ms_imps ms), + text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), + char '}' + ] + +name_of_summary :: ModSummary -> ModuleName +name_of_summary = moduleName . ms_mod +\end{code} diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index f4fe0f1..af2a45b 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -18,29 +18,33 @@ import Maybes ( maybeToBool ) import Outputable import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM ) import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs ) -import Panic ( panic ) import CmLink ( PersistentLinkerState, emptyPLS, Linkable(..), link, LinkResult(..), filterModuleLinkables, modname_of_linkable, is_package_linkable, findModuleLinkable ) +import CmTypes +import HscTypes import Interpreter ( HValue ) -import CmSummarise ( summarise, ModSummary(..), - name_of_summary, {-, is_source_import-} ) import Module ( ModuleName, moduleName, packageOfModule, isModuleInThisPackage, PackageName, moduleEnvElts, moduleNameUserString ) import CmStaticInfo ( Package(..), PackageConfigInfo, GhciMode ) -import DriverPipeline ( compile, preprocess, doLink, CompResult(..) ) +import DriverPipeline +import GetImports import HscTypes ( HomeSymbolTable, HomeIfaceTable, PersistentCompilerState, ModDetails(..) ) import Name ( lookupNameEnv ) +import Module import PrelNames ( mainName ) import HscMain ( initPersistentCompilerState ) import Finder ( findModule, emptyHomeDirCache ) import DriverUtil ( BarfKind(..) ) +import Util +import Panic ( panic ) + import Exception ( throwDyn ) -import IO ( hPutStrLn, stderr ) +import IO \end{code} @@ -143,7 +147,7 @@ cmLoadModule cmstate1 rootname -- Throw away the old home dir cache emptyHomeDirCache - putStr "cmLoadModule: downsweep begins\n" + hPutStr stderr "cmLoadModule: downsweep begins\n" mg2unsorted <- downsweep [rootname] let modnames1 = map name_of_summary mg1 @@ -159,8 +163,8 @@ cmLoadModule cmstate1 rootname -- upsweep. let mg2_with_srcimps = topological_sort True mg2unsorted - putStrLn "after tsort:\n" - putStrLn (showSDoc (vcat (map ppr mg2))) + hPutStrLn stderr "after tsort:\n" + hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) -- Because we don't take into account source imports when doing -- the topological sort, there shouldn't be any cycles in mg2. @@ -189,9 +193,9 @@ cmLoadModule cmstate1 rootname then -- Easy; just relink it all. - do putStrLn "UPSWEEP COMPLETELY SUCCESSFUL" + do hPutStrLn stderr "UPSWEEP COMPLETELY SUCCESSFUL" linkresult - <- link doLink ghci_mode (any exports_main (moduleEnvElts hst3)) + <- link ghci_mode (any exports_main (moduleEnvElts hst3)) newLis pls1 case linkresult of LinkErrs _ _ @@ -208,7 +212,7 @@ cmLoadModule cmstate1 rootname -- Tricky. We need to back out the effects of compiling any -- half-done cycles, both so as to clean up the top level envs -- and to avoid telling the interactive linker to link them. - do putStrLn "UPSWEEP PARTIALLY SUCCESSFUL" + do hPutStrLn stderr "UPSWEEP PARTIALLY SUCCESSFUL" let modsDone_names = map name_of_summary modsDone @@ -225,7 +229,7 @@ cmLoadModule cmstate1 rootname let linkables_to_link = map (findModuleLinkable ui4) mods_to_keep_names - linkresult <- link doLink ghci_mode False linkables_to_link pls1 + linkresult <- link ghci_mode False linkables_to_link pls1 case linkresult of LinkErrs _ _ -> panic "cmLoadModule: link failed (2)" @@ -407,7 +411,7 @@ downsweep rootNm | trace ("getSummary: "++ showSDoc (ppr nm)) True = do found <- findModule nm case found of - Just (mod, location) -> summarise preprocess mod location + Just (mod, location) -> summarise mod location Nothing -> throwDyn (OtherError ("no signs of life for module `" ++ showSDoc (ppr nm) ++ "'")) @@ -428,4 +432,24 @@ downsweep rootNm if null newHomeSummaries then return homeSummaries else loop (newHomeSummaries ++ homeSummaries) + + +summarise :: Module -> ModuleLocation -> IO ModSummary +summarise mod location + | isModuleInThisPackage mod + = do let hs_fn = unJust (ml_hs_file location) "summarise" + hspp_fn <- preprocess hs_fn + modsrc <- readFile hspp_fn + let (srcimps,imps) = getImports modsrc + +-- maybe_timestamp +-- <- case ml_hs_file location of +-- Nothing -> return Nothing +-- Just src_fn -> getModificationTime src_fn >>= Just + + return (ModSummary mod location{ml_hspp_file=Just hspp_fn} + srcimps imps + {-maybe_timestamp-} ) + | otherwise + = return (ModSummary mod location [] []) \end{code} diff --git a/ghc/compiler/ghci/StgInterp.lhs b/ghc/compiler/ghci/StgInterp.lhs index 1bf01da..f328ec0 100644 --- a/ghc/compiler/ghci/StgInterp.lhs +++ b/ghc/compiler/ghci/StgInterp.lhs @@ -6,7 +6,7 @@ \begin{code} module StgInterp ( - ClosureEnv, ItblEnv, + ClosureEnv, ItblEnv, filterRdrNameEnv, linkIModules, stgToInterpSyn, ) where @@ -39,6 +39,7 @@ import Literal ( Literal(..) ) import Type ( Type, typePrimRep, deNoteType, repType, funResultTy ) import DataCon ( DataCon, dataConTag, dataConRepArgTys ) import ClosureInfo ( mkVirtHeapOffsets ) +import Module ( ModuleName ) import Name ( toRdrName ) import UniqFM import UniqSet @@ -76,6 +77,11 @@ type ItblEnv = FiniteMap RdrName (Ptr StgInfoTable) type ClosureEnv = FiniteMap RdrName HValue emptyClosureEnv = emptyFM +-- remove all entries for a given set of modules from the environment +filterRdrNameEnv :: [ModuleName] -> FiniteMap RdrName a -> FiniteMap RdrName a +filterRdrNameEnv mods env + = filterFM (\n _ -> rdrNameModule n `notElem` mods) env + -- --------------------------------------------------------------------------- -- Run our STG program through the interpreter -- --------------------------------------------------------------------------- @@ -421,7 +427,7 @@ linkIModules gce gie mods = do let {-rec-} new_gce = addListToFM gce (zip top_level_binders new_rhss) new_rhss = map (\b -> evalP (bindee b) emptyUFM) new_binds - ---vvvvvvvvv---------------------------------------^^^^^^^^^-- circular + --vvvvvvvvv----------------------------------------^^^^^^^^^-- circular new_binds = linkIBinds final_gie new_gce binds return (new_binds, final_gie, new_gce) @@ -433,9 +439,6 @@ linkIModules gce gie mods = do -- up and not cache them in the source symbol tables. The interpreted -- code will still be referenced in the source symbol tables. --- JRS 001025: above comment is probably out of date ... interpret --- with care. - linkIBinds :: ItblEnv -> ClosureEnv -> [UnlinkedIBind] -> [LinkedIBind] linkIBinds ie ce binds = map (linkIBind ie ce) binds @@ -1136,16 +1139,16 @@ vecret_entry 6 = mci_constr7_entry vecret_entry 7 = mci_constr8_entry -- entry point for direct returns for created constr itbls -foreign label "mci_constr_entry" mci_constr_entry :: Addr +foreign label "stg_mci_constr_entry" mci_constr_entry :: Addr -- and the 8 vectored ones -foreign label "mci_constr1_entry" mci_constr1_entry :: Addr -foreign label "mci_constr2_entry" mci_constr2_entry :: Addr -foreign label "mci_constr3_entry" mci_constr3_entry :: Addr -foreign label "mci_constr4_entry" mci_constr4_entry :: Addr -foreign label "mci_constr5_entry" mci_constr5_entry :: Addr -foreign label "mci_constr6_entry" mci_constr6_entry :: Addr -foreign label "mci_constr7_entry" mci_constr7_entry :: Addr -foreign label "mci_constr8_entry" mci_constr8_entry :: Addr +foreign label "stg_mci_constr1_entry" mci_constr1_entry :: Addr +foreign label "stg_mci_constr2_entry" mci_constr2_entry :: Addr +foreign label "stg_mci_constr3_entry" mci_constr3_entry :: Addr +foreign label "stg_mci_constr4_entry" mci_constr4_entry :: Addr +foreign label "stg_mci_constr5_entry" mci_constr5_entry :: Addr +foreign label "stg_mci_constr6_entry" mci_constr6_entry :: Addr +foreign label "stg_mci_constr7_entry" mci_constr7_entry :: Addr +foreign label "stg_mci_constr8_entry" mci_constr8_entry :: Addr diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 06a44fc..8fe5de4 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPipeline.hs,v 1.26 2000/11/15 15:43:31 sewardj Exp $ +-- $Id: DriverPipeline.hs,v 1.27 2000/11/16 15:57:05 simonmar Exp $ -- -- GHC Driver -- @@ -22,8 +22,8 @@ module DriverPipeline ( #include "HsVersions.h" -import CmSummarise -import CmLink +import CmTypes +import GetImports import DriverState import DriverUtil import DriverMkDepend diff --git a/ghc/compiler/main/GetImports.hs b/ghc/compiler/main/GetImports.hs new file mode 100644 index 0000000..deeef72 --- /dev/null +++ b/ghc/compiler/main/GetImports.hs @@ -0,0 +1,85 @@ +----------------------------------------------------------------------------- +-- $Id: GetImports.hs,v 1.1 2000/11/16 15:57:05 simonmar Exp $ +-- +-- GHC Driver program +-- +-- (c) Simon Marlow 2000 +-- +----------------------------------------------------------------------------- + +module GetImports ( getImports ) where + +import Module +import List +import Char + +getImports :: String -> ([ModuleName], [ModuleName]) +getImports str + = let all_imps = (nub . gmiBase . clean) str + srcs = concatMap (either unit nil) all_imps + normals = concatMap (either nil unit) all_imps + unit x = [x] + nil x = [] + in (srcs, normals) + +-- really get the imports from a de-litted, cpp'd, de-literal'd string +-- Lefts are source imports. Rights are normal ones. +gmiBase :: String -> [Either ModuleName ModuleName] +gmiBase s + = f (words s) + where + f ("foreign" : "import" : ws) = f ws + f ("import" : "{-#" : "SOURCE" : "#-}" : "qualified" : m : ws) + = Left (mkMN m) : f ws + f ("import" : "{-#" : "SOURCE" : "#-}" : m : ws) + = Left (mkMN m) : f ws + f ("import" : "qualified" : m : ws) + = Right (mkMN m) : f ws + f ("import" : m : ws) + = Right (mkMN m) : f ws + f (w:ws) = f ws + f [] = [] + + mkMN str = mkModuleName (takeWhile isModId str) + isModId c = isAlphaNum c || c `elem` "'_" + +-- remove literals and comments from a string +clean :: String -> String +clean s + = keep s + where + -- running through text we want to keep + keep [] = [] + keep ('"':cs) = dquote cs -- " + -- try to eliminate single quotes when they're part of + -- an identifier... + keep (c:'\'':cs) | isAlphaNum c || c == '_' = keep (dropWhile (=='\'') cs) + keep ('\'':cs) = squote cs + keep ('-':'-':cs) = linecomment cs + keep ('{':'-':'#':' ':cs) = "{-# " ++ keep cs + keep ('{':'-':cs) = runcomment cs -- -} + keep (c:cs) = c : keep cs + + -- in a double-quoted string + dquote [] = [] + dquote ('\\':'\"':cs) = dquote cs -- " + dquote ('\\':'\\':cs) = dquote cs + dquote ('\"':cs) = keep cs -- " + dquote (c:cs) = dquote cs + + -- in a single-quoted string + squote [] = [] + squote ('\\':'\'':cs) = squote cs + squote ('\\':'\\':cs) = squote cs + squote ('\'':cs) = keep cs + squote (c:cs) = squote cs + + -- in a line comment + linecomment [] = [] + linecomment ('\n':cs) = '\n':keep cs + linecomment (c:cs) = linecomment cs + + -- in a running comment + runcomment [] = [] + runcomment ('-':'}':cs) = keep cs + runcomment (c:cs) = runcomment cs diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index f7abbb0..e1bfd15 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -173,7 +173,7 @@ hscRecomp dflags location maybe_checked_iface hst hit pcs_ch <- renameModule dflags hit hst pcs_ch this_mod rdr_module ; case maybe_rn_result of { Nothing -> return (HscFail pcs_rn); - Just (print_unqualified, (is_exported, new_iface, rn_hs_decls)) -> do { + Just (print_unqualified, is_exported, new_iface, rn_hs_decls) -> do { ------------------- -- TYPECHECK @@ -372,8 +372,7 @@ hscExpr hscExpr dflags hst hit pcs this_module expr = do { -- Parse it - let unqual = unQualInScope - ; maybe_parsed <- myParseExpr dflags expr + maybe_parsed <- myParseExpr dflags expr ; case maybe_parsed of { Nothing -> return (HscFail pcs_ch); Just parsed_expr -> do { diff --git a/ghc/compiler/main/Interpreter.hs b/ghc/compiler/main/Interpreter.hs index 928f8ef..c39f658 100644 --- a/ghc/compiler/main/Interpreter.hs +++ b/ghc/compiler/main/Interpreter.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: Interpreter.hs,v 1.3 2000/11/08 14:52:06 simonpj Exp $ +-- $Id: Interpreter.hs,v 1.4 2000/11/16 15:57:05 simonmar Exp $ -- -- Interpreter subsystem wrapper -- @@ -39,6 +39,7 @@ import Outputable --------------------------------------------- -- NO! No interpreter; generate stubs for all the bits + --------------------------------------------- type ClosureEnv = () @@ -57,4 +58,5 @@ linkIModules = error "linkIModules" stgToInterpSyn = error "linkIModules" loadObjs = error "loadObjs" resolveObjs = error "loadObjs" +interactiveUI = error "interactiveUI" #endif diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 8283eb5..d1a1636 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,6 +1,6 @@ {-# OPTIONS -W -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.23 2000/11/16 11:39:37 simonmar Exp $ +-- $Id: Main.hs,v 1.24 2000/11/16 15:57:06 simonmar Exp $ -- -- GHC Driver program -- @@ -16,7 +16,10 @@ module Main (main) where #include "HsVersions.h" import CompManager +import Interpreter +#ifdef GHCI import InteractiveUI +#endif import DriverPipeline import DriverState import DriverFlags @@ -281,6 +284,9 @@ beginMake pkg_details mods return () _ -> throwDyn (UsageError "only one module allowed with --make") +#ifndef GHCI +beginInteractive = throwDyn (OtherError "not build for interactive use") +#else beginInteractive pkg_details mods = do state <- cmInit pkg_details Interactive case mods of @@ -289,5 +295,4 @@ beginInteractive pkg_details mods _ -> throwDyn (UsageError "only one module allowed with --interactive") interactiveUI state - - +#endif -- 1.7.10.4