Commit f212eb91 authored by simonmar's avatar simonmar
Browse files

[project @ 2000-11-16 15:57:05 by simonmar]

Moving things around a bit to avoid cycles.

Further progress on interactive linker.
parent 490cba33
......@@ -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}
%
% (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}
......@@ -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}
......@@ -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
......
-----------------------------------------------------------------------------
-- $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
......
%
% (c) The University of Glasgow, 2000
%
\section[CmSummarise]{Module summariser for GHCI}
-----------------------------------------------------------------------------
-- $Id: GetImports.hs,v 1.1 2000/11/16 15:57:05 simonmar Exp $
--
-- GHC Driver program
--
-- (c) Simon Marlow 2000
--
-----------------------------------------------------------------------------
\begin{code}
module CmSummarise ( ModSummary(..), summarise, name_of_summary,
getImports {-, source_has_changed-} )
where
module GetImports ( getImports ) 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.
import List
import Char
\begin{code}
getImports :: String -> ([ModuleName], [ModuleName])
getImports str
= let all_imps = (nub . gmiBase . clean) str
......@@ -172,4 +83,3 @@ clean s
runcomment [] = []