Moving things around a bit to avoid cycles.
Further progress on interactive linker.
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}
= 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
\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"
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}
+++ /dev/null
-%
-% (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}
--- /dev/null
+%
+% (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}
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}
-- 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
-- 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.
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 _ _
-- 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
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)"
| 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) ++ "'"))
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}
\begin{code}
module StgInterp (
- ClosureEnv, ItblEnv,
+ ClosureEnv, ItblEnv, filterRdrNameEnv,
linkIModules,
stgToInterpSyn,
) where
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
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
-- ---------------------------------------------------------------------------
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)
-- 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
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
--
#include "HsVersions.h"
-import CmSummarise
-import CmLink
+import CmTypes
+import GetImports
import DriverState
import DriverUtil
import DriverMkDepend
--- /dev/null
+-----------------------------------------------------------------------------
+-- $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
<- 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
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 {
-----------------------------------------------------------------------------
--- $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
--
---------------------------------------------
-- NO! No interpreter; generate stubs for all the bits
+
---------------------------------------------
type ClosureEnv = ()
stgToInterpSyn = error "linkIModules"
loadObjs = error "loadObjs"
resolveObjs = error "loadObjs"
+interactiveUI = error "interactiveUI"
#endif
{-# 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
--
#include "HsVersions.h"
import CompManager
+import Interpreter
+#ifdef GHCI
import InteractiveUI
+#endif
import DriverPipeline
import DriverState
import DriverFlags
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
_ -> throwDyn (UsageError
"only one module allowed with --interactive")
interactiveUI state
-
-
+#endif
projects / ghc-hetmet.git / commitdiff