summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ghc/compiler/compMan/CmLink.lhs4
-rw-r--r--ghc/compiler/compMan/CompManager.lhs113
-rw-r--r--ghc/compiler/ghci/InteractiveUI.hs207
-rw-r--r--ghc/compiler/ghci/InterpSyn.lhs10
-rw-r--r--ghc/compiler/ghci/MCI_make_constr.hi-boot10
-rw-r--r--ghc/compiler/ghci/StgInterp.lhs81
-rw-r--r--ghc/compiler/main/DriverPipeline.hs8
-rw-r--r--ghc/compiler/main/HscMain.lhs103
-rw-r--r--ghc/compiler/main/Main.hs11
9 files changed, 336 insertions, 211 deletions
diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs
index 0281772dcd..d3ed436224 100644
--- a/ghc/compiler/compMan/CmLink.lhs
+++ b/ghc/compiler/compMan/CmLink.lhs
@@ -205,8 +205,8 @@ invalidLinkable = throwDyn (OtherError "linkable doesn't contain entirely object
-- various environments any previous versions of these modules.
linkFinish pls mods ul_trees = do
resolveObjs
- let itbl_env' = filterRdrNameEnv mods (itbl_env pls)
- closure_env' = filterRdrNameEnv mods (closure_env pls)
+ let itbl_env' = filterNameEnv mods (itbl_env pls)
+ closure_env' = filterNameEnv mods (closure_env pls)
stuff = [ (trees,itbls) | Trees trees itbls <- ul_trees ]
(ibinds, new_itbl_env, new_closure_env) <-
diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index 60dec5adbb..5b9e31e6e0 100644
--- a/ghc/compiler/compMan/CompManager.lhs
+++ b/ghc/compiler/compMan/CompManager.lhs
@@ -6,7 +6,7 @@
\begin{code}
module CompManager ( cmInit, cmLoadModule, cmUnload,
#ifdef GHCI
- cmGetExpr, cmTypeExpr, cmRunExpr,
+ cmGetExpr, cmRunExpr,
#endif
CmState, emptyCmState -- abstract
)
@@ -39,13 +39,14 @@ import DriverPhases
import DriverUtil ( BarfKind(..), splitFilename3 )
import ErrUtils ( showPass )
import Util
+import DriverUtil
import Outputable
import Panic ( panic )
import CmdLineOpts ( DynFlags(..) )
#ifdef GHCI
import Interpreter ( HValue )
-import HscMain ( hscExpr, hscTypeExpr )
+import HscMain ( hscExpr )
import RdrName
import Type ( Type )
import PrelGHC ( unsafeCoerce# )
@@ -74,34 +75,22 @@ cmGetExpr :: CmState
-> DynFlags
-> ModuleName
-> String
- -> IO (CmState, Maybe HValue)
+ -> IO (CmState, Maybe (HValue, PrintUnqualified, Type))
cmGetExpr cmstate dflags modname expr
- = do (new_pcs, maybe_unlinked_iexpr) <-
+ = do (new_pcs, maybe_stuff) <-
hscExpr dflags hst hit pcs (mkHomeModule modname) expr
- case maybe_unlinked_iexpr of
+ case maybe_stuff of
Nothing -> return (cmstate{ pcs=new_pcs }, Nothing)
- Just uiexpr -> do
+ Just (uiexpr, print_unqual, ty) -> do
hValue <- linkExpr pls uiexpr
- return (cmstate{ pcs=new_pcs }, Just hValue)
+ return (cmstate{ pcs=new_pcs },
+ Just (hValue, print_unqual, ty))
-- ToDo: check that the module we passed in is sane/exists?
where
CmState{ pcs=pcs, pcms=pcms, pls=pls } = cmstate
PersistentCMState{ hst=hst, hit=hit } = pcms
-cmTypeExpr :: CmState
- -> DynFlags
- -> ModuleName
- -> String
- -> IO (CmState, Maybe (PrintUnqualified, Type))
-cmTypeExpr cmstate dflags modname expr
- = do (new_pcs, expr_type) <-
- hscTypeExpr dflags hst hit pcs (mkHomeModule modname) expr
- return (cmstate{ pcs=new_pcs }, expr_type)
- where
- CmState{ pcs=pcs, pcms=pcms, pls=pls } = cmstate
- PersistentCMState{ hst=hst, hit=hit } = pcms
-
-- The HValue should represent a value of type IO () (Perhaps IO a?)
cmRunExpr :: HValue -> IO ()
cmRunExpr hval
@@ -208,7 +197,7 @@ cmLoadModule cmstate1 rootname
showPass dflags "Chasing dependencies"
when (verb >= 1 && ghci_mode == Batch) $
- hPutStrLn stderr ("ghc: chasing modules from: " ++ rootname)
+ hPutStrLn stderr (prog_name ++ ": chasing modules from: " ++ rootname)
mg2unsorted <- downsweep [rootname]
@@ -243,7 +232,7 @@ cmLoadModule cmstate1 rootname
let threaded2 = CmThreaded pcs1 hst2 hit2
(upsweep_complete_success, threaded3, modsDone, newLis)
- <- upsweep_mods ghci_mode ui2 reachable_from threaded2 mg2
+ <- upsweep_mods ghci_mode dflags ui2 reachable_from threaded2 mg2
let ui3 = add_to_ui ui2 newLis
let (CmThreaded pcs3 hst3 hit3) = threaded3
@@ -363,6 +352,7 @@ data CmThreaded -- stuff threaded through individual module compilations
-- Compile multiple modules, stopping as soon as an error appears.
-- There better had not be any cyclic groups here -- we check for them.
upsweep_mods :: GhciMode
+ -> DynFlags
-> UnlinkedImage -- old linkables
-> (ModuleName -> [ModuleName]) -- to construct downward closures
-> CmThreaded -- PCS & HST & HIT
@@ -373,26 +363,26 @@ upsweep_mods :: GhciMode
[ModSummary], -- mods which succeeded
[Linkable]) -- new linkables
-upsweep_mods ghci_mode oldUI reachable_from threaded
+upsweep_mods ghci_mode dflags oldUI reachable_from threaded
[]
= return (True, threaded, [], [])
-upsweep_mods ghci_mode oldUI reachable_from threaded
+upsweep_mods ghci_mode dflags oldUI reachable_from threaded
((CyclicSCC ms):_)
= do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++
unwords (map (moduleNameUserString.name_of_summary) ms))
return (False, threaded, [], [])
-upsweep_mods ghci_mode oldUI reachable_from threaded
+upsweep_mods ghci_mode dflags oldUI reachable_from threaded
((AcyclicSCC mod):mods)
= do (threaded1, maybe_linkable)
- <- upsweep_mod ghci_mode oldUI threaded mod
+ <- upsweep_mod ghci_mode dflags oldUI threaded mod
(reachable_from (name_of_summary mod))
case maybe_linkable of
Just linkable
-> -- No errors; do the rest
do (restOK, threaded2, modOKs, linkables)
- <- upsweep_mods ghci_mode oldUI reachable_from
+ <- upsweep_mods ghci_mode dflags oldUI reachable_from
threaded1 mods
return (restOK, threaded2, mod:modOKs, linkable:linkables)
Nothing -- we got a compilation error; give up now
@@ -417,29 +407,29 @@ maybe_getFileLinkable mod_name obj_fn
upsweep_mod :: GhciMode
+ -> DynFlags
-> UnlinkedImage
-> CmThreaded
-> ModSummary
-> [ModuleName]
-> IO (CmThreaded, Maybe Linkable)
-upsweep_mod ghci_mode oldUI threaded1 summary1 reachable_from_here
- = do hPutStr stderr ("ghc: module "
- ++ moduleNameUserString (name_of_summary summary1) ++ ": ")
+upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_from_here
+ = do
let mod_name = name_of_summary summary1
+ let verb = verbosity dflags
+
+ when (verb == 1) $
+ if (ghci_mode == Batch)
+ then hPutStr stderr (prog_name ++ ": module "
+ ++ moduleNameUserString mod_name
+ ++ ": ")
+ else hPutStr stderr ("Compiling "
+ ++ moduleNameUserString mod_name
+ ++ " ... ")
+
let (CmThreaded pcs1 hst1 hit1) = threaded1
- let old_iface = lookupUFM hit1 (name_of_summary summary1)
-
- -- We *have* to compile it if we're in batch mode and we can't see
- -- a previous linkable for it on disk.
- compilation_mandatory
- <- if ghci_mode /= Batch then return False
- else case ml_obj_file (ms_location summary1) of
- Nothing -> do --putStrLn "cmcm: object?!"
- return True
- Just obj_fn -> do --putStrLn ("cmcm: old obj " ++ obj_fn)
- b <- doesFileExist obj_fn
- return (not b)
+ let old_iface = lookupUFM hit1 mod_name
let maybe_oldUI_linkable = findModuleLinkable_maybe oldUI mod_name
maybe_oldDisk_linkable
@@ -483,25 +473,42 @@ upsweep_mod ghci_mode oldUI threaded1 summary1 reachable_from_here
-- linkable, meaning that compilation wasn't needed, and the
-- new details were manufactured from the old iface.
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)
+ -> do let hst2 = addToUFM hst1 mod_name new_details
+ hit2 = addToUFM hit1 mod_name new_iface
+ threaded2 = CmThreaded pcs2 hst2 hit2
+
+ if ghci_mode == Interactive && verb >= 1 then
+ -- if we're using an object file, tell the user
+ case maybe_old_linkable of
+ Just (LM _ _ objs@(DotO _:_))
+ -> do hPutStr stderr (showSDoc (space <>
+ parens (hsep (text "using":
+ punctuate comma
+ [ text o | DotO o <- objs ]))))
+ when (verb > 1) $ hPutStrLn stderr ""
+ _ -> return ()
+ else
+ return ()
+
+ when (verb == 1) $ hPutStrLn stderr ""
+ return (threaded2, Just old_linkable)
-- Compilation really did happen, and succeeded. A new
-- details, iface and linkable are returned.
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)
+ -> do let hst2 = addToUFM hst1 mod_name new_details
+ hit2 = addToUFM hit1 mod_name new_iface
+ threaded2 = CmThreaded pcs2 hst2 hit2
+
+ when (verb == 1) $ hPutStrLn stderr ""
+ return (threaded2, Just new_linkable)
-- Compilation failed. compile may still have updated
-- the PCS, tho.
CompErrs pcs2
- -> let threaded2 = CmThreaded pcs2 hst1 hit1
- in return (threaded2, Nothing)
-
+ -> do let threaded2 = CmThreaded pcs2 hst1 hit1
+ when (verb == 1) $ hPutStrLn stderr ""
+ return (threaded2, Nothing)
-- Remove unwanted modules from the top level envs (HST, HIT, UI).
removeFromTopLevelEnvs :: [ModuleName]
diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index b6c3829054..863176b5cd 100644
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.14 2000/11/22 17:51:16 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.15 2000/11/24 17:09:52 simonmar Exp $
--
-- GHC Interactive User Interface
--
@@ -25,7 +25,10 @@ import Exception
import Readline
import IOExts
+import Numeric
+import List
import System
+import CPUTime
import Directory
import IO
import Char
@@ -51,12 +54,15 @@ commands = [
("reload", reloadModule),
("set", setOptions),
("type", typeOfExpr),
+ ("unset", unsetOptions),
("quit", quit)
]
shortHelpText = "use :? for help.\n"
helpText = "\
+\ Commands available from the prompt:\n\
+\\
\ <expr> evaluate <expr>\n\
\ :add <filename> add a module to the current set\n\
\ :cd <dir> change directory to <dir>\n\
@@ -65,13 +71,21 @@ helpText = "\
\ :module <mod> set the context for expression evaluation to <mod>\n\
\ :reload reload the current module set\n\
\ :set <option> ... set options\n\
+\ :unset <option> ... unset options\n\
\ :type <expr> show the type of <expr>\n\
\ :quit exit GHCi\n\
\ :!<command> run the shell command <command>\n\
+\\
+\ Options for `:set' and `:unset':\n\
+\\
+\ +s print timing/memory stats after each evaluation\n\
+\ +t print type after evaluation\n\
+\ -<flags> most GHC command line flags can also be set here\n\
+\ (eg. -v2, -fglasgow-exts, etc.)\n\
\"
-interactiveUI :: CmState -> [ModuleName] -> IO ()
-interactiveUI st mods = do
+interactiveUI :: CmState -> Maybe FilePath -> IO ()
+interactiveUI cmstate mod = do
hPutStrLn stdout ghciWelcomeMsg
hFlush stdout
hSetBuffering stdout NoBuffering
@@ -80,6 +94,11 @@ interactiveUI st mods = do
pkgs <- getPackageInfo
linkPackages (reverse pkgs)
+ (cmstate', ok, mods) <-
+ case mod of
+ Nothing -> return (cmstate, True, [])
+ Just m -> cmLoadModule cmstate m
+
#ifndef NO_READLINE
Readline.initialize
#endif
@@ -90,7 +109,8 @@ interactiveUI st mods = do
(unGHCi uiLoop) GHCiState{ modules = mods,
current_module = this_mod,
target = Nothing,
- cmstate = st }
+ cmstate = cmstate',
+ options = [ShowTiming]}
return ()
uiLoop :: GHCi ()
@@ -128,15 +148,22 @@ runCommand c =
doCommand c
doCommand (':' : command) = specialCommand command
-doCommand expr
+doCommand expr = timeIt (evalExpr expr)
+
+evalExpr expr
= do st <- getGHCiState
dflags <- io (getDynFlags)
- (new_cmstate, maybe_hvalue) <-
+ (new_cmstate, maybe_stuff) <-
io (cmGetExpr (cmstate st) dflags (current_module st) expr)
setGHCiState st{cmstate = new_cmstate}
- case maybe_hvalue of
+ case maybe_stuff of
Nothing -> return ()
- Just hv -> io (cmRunExpr hv)
+ Just (hv, unqual, ty)
+ -> do io (cmRunExpr hv)
+ b <- isOptionSet ShowType
+ if b then io (printForUser stdout unqual (text "::" <+> ppr ty))
+ else return ()
+
{-
let (mod,'.':str) = break (=='.') expr
case cmLookupSymbol (mkOrig varName (mkModuleName mod) (_PK_ str)) (cmstate st) of
@@ -181,12 +208,14 @@ changeDirectory :: String -> GHCi ()
changeDirectory = io . setCurrentDirectory
loadModule :: String -> GHCi ()
-loadModule path = do
+loadModule path = timeIt (loadModule' path)
+
+loadModule' path = do
state <- getGHCiState
cmstate1 <- io (cmUnload (cmstate state))
(cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
- let new_state = GHCiState {
+ let new_state = state{
cmstate = cmstate2,
modules = mods,
current_module = case mods of
@@ -216,35 +245,15 @@ reloadModule "" = do
setGHCiState state{cmstate=new_cmstate}
reloadModule _ = noArgs ":reload"
--- set options in the interpreter. Syntax is exactly the same as the
--- ghc command line, except that certain options aren't available (-C,
--- -E etc.)
---
--- This is pretty fragile: most options won't work as expected. ToDo:
--- figure out which ones & disallow them.
-setOptions :: String -> GHCi ()
-setOptions str =
- io (do leftovers <- processArgs static_flags (words str) []
- dyn_flags <- readIORef v_InitDynFlags
- writeIORef v_DynFlags dyn_flags
- leftovers <- processArgs dynamic_flags leftovers []
- dyn_flags <- readIORef v_DynFlags
- writeIORef v_InitDynFlags dyn_flags
- if (not (null leftovers))
- then throwDyn (OtherError ("unrecognised flags: " ++
- unwords leftovers))
- else return ()
- )
-
typeOfExpr :: String -> GHCi ()
typeOfExpr str
= do st <- getGHCiState
dflags <- io (getDynFlags)
- (st, maybe_ty) <- io (cmTypeExpr (cmstate st) dflags
+ (st, maybe_ty) <- io (cmGetExpr (cmstate st) dflags
(current_module st) str)
case maybe_ty of
Nothing -> return ()
- Just (unqual, ty) -> io (printForUser stdout unqual (ppr ty))
+ Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty))
quit :: String -> GHCi ()
quit _ = exitGHCi
@@ -252,6 +261,94 @@ quit _ = exitGHCi
shellEscape :: String -> GHCi ()
shellEscape str = io (system str >> return ())
+----------------------------------------------------------------------------
+-- Code for `:set'
+
+-- set options in the interpreter. Syntax is exactly the same as the
+-- ghc command line, except that certain options aren't available (-C,
+-- -E etc.)
+--
+-- This is pretty fragile: most options won't work as expected. ToDo:
+-- figure out which ones & disallow them.
+
+setOptions :: String -> GHCi ()
+setOptions ""
+ = do st <- getGHCiState
+ let opts = options st
+ io $ putStrLn (showSDoc (
+ text "options currently set: " <>
+ if null opts
+ then text "none."
+ else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
+ ))
+setOptions str
+ = do -- first, deal with the GHCi opts (+s, +t, etc.)
+ let opts = words str
+ (minus_opts, rest1) = partition isMinus opts
+ (plus_opts, rest2) = partition isPlus rest1
+
+ if (not (null rest2))
+ then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
+ else do
+
+ mapM setOpt plus_opts
+
+ -- now, the GHC flags
+ io (do leftovers <- processArgs static_flags minus_opts []
+ dyn_flags <- readIORef v_InitDynFlags
+ writeIORef v_DynFlags dyn_flags
+ leftovers <- processArgs dynamic_flags leftovers []
+ dyn_flags <- readIORef v_DynFlags
+ writeIORef v_InitDynFlags dyn_flags
+ if (not (null leftovers))
+ then throwDyn (OtherError ("unrecognised flags: " ++
+ unwords leftovers))
+ else return ()
+ )
+
+unsetOptions :: String -> GHCi ()
+unsetOptions str
+ = do -- first, deal with the GHCi opts (+s, +t, etc.)
+ let opts = words str
+ (minus_opts, rest1) = partition isMinus opts
+ (plus_opts, rest2) = partition isPlus rest1
+
+ if (not (null rest2))
+ then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
+ else do
+
+ mapM unsetOpt plus_opts
+
+ -- can't do GHC flags for now
+ if (not (null minus_opts))
+ then throwDyn (OtherError "can't unset GHC command-line flags")
+ else return ()
+
+isMinus ('-':s) = True
+isMinus _ = False
+
+isPlus ('+':s) = True
+isPlus _ = False
+
+setOpt ('+':str)
+ = case strToGHCiOpt str of
+ Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
+ Just o -> setOption o
+
+unsetOpt ('+':str)
+ = case strToGHCiOpt str of
+ Nothing -> io (putStrLn ("unknown option: `" ++ str ++ "'"))
+ Just o -> unsetOption o
+
+strToGHCiOpt :: String -> (Maybe GHCiOption)
+strToGHCiOpt "s" = Just ShowTiming
+strToGHCiOpt "t" = Just ShowType
+strToGHCiOpt _ = Nothing
+
+optToStr :: GHCiOption -> String
+optToStr ShowTiming = "s"
+optToStr ShowType = "t"
+
-----------------------------------------------------------------------------
-- GHCi monad
@@ -260,9 +357,12 @@ data GHCiState = GHCiState
modules :: [ModuleName],
current_module :: ModuleName,
target :: Maybe FilePath,
- cmstate :: CmState
+ cmstate :: CmState,
+ options :: [GHCiOption]
}
+data GHCiOption = ShowTiming | ShowType deriving Eq
+
defaultCurrentModule = mkModuleName "Prelude"
newtype GHCi a = GHCi { unGHCi :: GHCiState -> IO (GHCiState, a) }
@@ -274,6 +374,21 @@ instance Monad GHCi where
getGHCiState = GHCi $ \s -> return (s,s)
setGHCiState s = GHCi $ \_ -> return (s,())
+isOptionSet :: GHCiOption -> GHCi Bool
+isOptionSet opt
+ = do st <- getGHCiState
+ return (opt `elem` options st)
+
+setOption :: GHCiOption -> GHCi ()
+setOption opt
+ = do st <- getGHCiState
+ setGHCiState (st{ options = opt : filter (/= opt) (options st) })
+
+unsetOption :: GHCiOption -> GHCi ()
+unsetOption opt
+ = do st <- getGHCiState
+ setGHCiState (st{ options = filter (/= opt) (options st) })
+
io m = GHCi $ \s -> m >>= \a -> return (s,a)
ghciHandle h (GHCi m) = GHCi $ \s ->
@@ -308,3 +423,29 @@ findFile (d:ds) obj = do
let path = d ++ '/':obj
b <- doesFileExist path
if b then return path else findFile ds obj
+
+-----------------------------------------------------------------------------
+-- timing & statistics
+
+timeIt :: GHCi a -> GHCi a
+timeIt action
+ = do b <- isOptionSet ShowTiming
+ if not b
+ then action
+ else do allocs1 <- io $ getAllocations
+ time1 <- io $ getCPUTime
+ a <- action
+ allocs2 <- io $ getAllocations
+ time2 <- io $ getCPUTime
+ io $ printTimes (allocs2 - allocs1) (time2 - time1)
+ return a
+
+foreign import "getAllocations" getAllocations :: IO Int
+
+printTimes :: Int -> Integer -> IO ()
+printTimes allocs psecs
+ = do let secs = (fromIntegral psecs / (10^12)) :: Float
+ secs_str = showFFloat (Just 2) secs
+ putStrLn (showSDoc (
+ parens (text (secs_str "") <+> text "secs" <> comma <+>
+ int allocs <+> text "bytes")))
diff --git a/ghc/compiler/ghci/InterpSyn.lhs b/ghc/compiler/ghci/InterpSyn.lhs
index b5da82c6b0..ccb6963d28 100644
--- a/ghc/compiler/ghci/InterpSyn.lhs
+++ b/ghc/compiler/ghci/InterpSyn.lhs
@@ -9,7 +9,7 @@ module InterpSyn {- Todo: ( ... ) -} where
#include "HsVersions.h"
import Id
-import RdrName
+import Name
import PrimOp
import Outputable
@@ -232,16 +232,16 @@ showExprTag expr
-----------------------------------------------------------------------------
-- Instantiations of the IExpr type
-type UnlinkedIExpr = IExpr RdrName RdrName
+type UnlinkedIExpr = IExpr Name Name
type LinkedIExpr = IExpr Addr HValue
-type UnlinkedIBind = IBind RdrName RdrName
+type UnlinkedIBind = IBind Name Name
type LinkedIBind = IBind Addr HValue
-type UnlinkedAltAlg = AltAlg RdrName RdrName
+type UnlinkedAltAlg = AltAlg Name Name
type LinkedAltAlg = AltAlg Addr HValue
-type UnlinkedAltPrim = AltPrim RdrName RdrName
+type UnlinkedAltPrim = AltPrim Name Name
type LinkedAltPrim = AltPrim Addr HValue
-----------------------------------------------------------------------------
diff --git a/ghc/compiler/ghci/MCI_make_constr.hi-boot b/ghc/compiler/ghci/MCI_make_constr.hi-boot
index 8690f720a2..5fa29076ca 100644
--- a/ghc/compiler/ghci/MCI_make_constr.hi-boot
+++ b/ghc/compiler/ghci/MCI_make_constr.hi-boot
@@ -4,19 +4,15 @@ __export MCIzumakezuconstr
mcizumakezuconstrI
mcizumakezuconstr0
mcizumakezuconstrP
- mcizumakezuconstrPP
- mcizumakezuconstrPPP ;
+ mcizumakezuconstrPP ;
1 mcizumakezuconstr
:: __forall [a] => PrelGHC.Addrzh -> a ;
-1 mcizumakezuconstrI
- :: __forall [a] => PrelGHC.Addrzh -> PrelGHC.Intzh -> a ;
1 mcizumakezuconstr0
:: __forall [a] => PrelGHC.Addrzh -> a ;
+1 mcizumakezuconstrI
+ :: __forall [a] => PrelGHC.Addrzh -> PrelGHC.Intzh -> a ;
1 mcizumakezuconstrP
:: __forall [a a1] => PrelGHC.Addrzh -> a1 -> a ;
1 mcizumakezuconstrPP
:: __forall [a a1 a2] => PrelGHC.Addrzh -> a1 -> a2 -> a ;
-1 mcizumakezuconstrPPP
- :: __forall [a a1 a2 a3] => PrelGHC.Addrzh -> a1 -> a2 -> a3 -> a ;
-
diff --git a/ghc/compiler/ghci/StgInterp.lhs b/ghc/compiler/ghci/StgInterp.lhs
index 778b84bfec..f8deebaf2f 100644
--- a/ghc/compiler/ghci/StgInterp.lhs
+++ b/ghc/compiler/ghci/StgInterp.lhs
@@ -8,8 +8,8 @@
module StgInterp (
ClosureEnv, ItblEnv,
- filterRdrNameEnv, -- :: [ModuleName] -> FiniteMap RdrName a
- -- -> FiniteMap RdrName a
+ filterNameEnv, -- :: [ModuleName] -> FiniteMap Name a
+ -- -> FiniteMap Name a
linkIModules, -- :: ItblEnv -> ClosureEnv
-- -> [([UnlinkedIBind], ItblEnv)]
@@ -58,19 +58,15 @@ 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 Module ( ModuleName, moduleName )
+import RdrName
+import Name
+import Util
import UniqFM
import UniqSet
import {-# SOURCE #-} MCI_make_constr
-import IOExts ( unsafePerformIO, unsafeInterleaveIO, fixIO ) -- ToDo: remove
-import PrelGHC --( unsafeCoerce#, dataToTag#,
- -- indexPtrOffClosure#, indexWordOffClosure# )
-import PrelAddr ( Addr(..) )
-import PrelFloat ( Float(..), Double(..) )
-import Bits
import FastString
import GlaExts ( Int(..) )
import Module ( moduleNameFS )
@@ -79,30 +75,37 @@ import TyCon ( TyCon, isDataTyCon, tyConDataCons, tyConFamilySize )
import Class ( Class, classTyCon )
import InterpSyn
import StgSyn
-import Addr
-import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isUnqual )
import FiniteMap
-import Panic ( panic )
import OccName ( occNameString )
import ErrUtils ( showPass, dumpIfSet_dyn )
import CmdLineOpts ( DynFlags, DynFlag(..) )
+import Panic ( panic )
+import IOExts
+import Addr
+import Bits
import Foreign
import CTypes
+
import IO
+import PrelGHC --( unsafeCoerce#, dataToTag#,
+ -- indexPtrOffClosure#, indexWordOffClosure# )
+import PrelAddr ( Addr(..) )
+import PrelFloat ( Float(..), Double(..) )
+
-- ---------------------------------------------------------------------------
-- Environments needed by the linker
-- ---------------------------------------------------------------------------
-type ItblEnv = FiniteMap RdrName (Ptr StgInfoTable)
-type ClosureEnv = FiniteMap RdrName HValue
+type ItblEnv = FiniteMap Name (Ptr StgInfoTable)
+type ClosureEnv = FiniteMap Name 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
+filterNameEnv :: [ModuleName] -> FiniteMap Name a -> FiniteMap Name a
+filterNameEnv mods env
+ = filterFM (\n _ -> moduleName (nameModule n) `notElem` mods) env
-- ---------------------------------------------------------------------------
-- Turn an UnlinkedIExpr into a value we can run, for the interpreter
@@ -165,7 +168,7 @@ conapp2expr :: UniqSet Id -> DataCon -> [StgArg] -> UnlinkedIExpr
conapp2expr ie dcon args
= mkConApp con_rdrname reps exprs
where
- con_rdrname = toRdrName dcon
+ con_rdrname = getName dcon
exprs = map (arg2expr ie) inHeapOrder
reps = map repOfArg inHeapOrder
inHeapOrder = toHeapOrder args
@@ -181,7 +184,7 @@ foreign label "PrelBase_Izh_con_info" prelbase_Izh_con_info :: Addr
-- Handle most common cases specially; do the rest with a generic
-- mechanism (deferred till later :)
-mkConApp :: RdrName -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
+mkConApp :: Name -> [Rep] -> [UnlinkedIExpr] -> UnlinkedIExpr
mkConApp nm [] [] = ConApp nm
mkConApp nm [RepI] [a1] = ConAppI nm a1
mkConApp nm [RepP] [a1] = ConAppP nm a1
@@ -403,7 +406,7 @@ mkVar ie rep var
RepF -> VarF
RepD -> VarD
RepP -> VarP) var
- | otherwise = Native (toRdrName var)
+ | otherwise = Native (getName var)
mkRec RepI = RecI
mkRec RepP = RecP
@@ -430,6 +433,11 @@ id2VaaRep var = (var, repOfId var)
-- Link interpretables into something we can run
-- ---------------------------------------------------------------------------
+GLOBAL_VAR(cafTable, [], [HValue])
+
+addCAF :: HValue -> IO ()
+addCAF x = do xs <- readIORef cafTable; writeIORef cafTable (x:xs)
+
linkIModules :: ItblEnv -- incoming global itbl env; returned updated
-> ClosureEnv -- incoming global closure env; returned updated
-> [([UnlinkedIBind], ItblEnv)]
@@ -437,7 +445,7 @@ linkIModules :: ItblEnv -- incoming global itbl env; returned updated
linkIModules gie gce mods = do
let (bindss, ies) = unzip mods
binds = concat bindss
- top_level_binders = map (toRdrName.binder) binds
+ top_level_binders = map (getName.binder) binds
final_gie = foldr plusFM gie ies
(new_binds, new_gce) <-
@@ -614,7 +622,7 @@ lookupCon ie con =
Just (Ptr addr) -> return addr
Nothing -> do
-- try looking up in the object files.
- m <- lookupSymbol (rdrNameToCLabel con "con_info")
+ m <- lookupSymbol (nameToCLabel con "con_info")
case m of
Just addr -> return addr
Nothing -> pprPanic "linkIExpr" (ppr con)
@@ -625,7 +633,7 @@ lookupNullaryCon ie con =
Just (Ptr addr) -> return (ConApp addr)
Nothing -> do
-- try looking up in the object files.
- m <- lookupSymbol (rdrNameToCLabel con "closure")
+ m <- lookupSymbol (nameToCLabel con "closure")
case m of
Just (A# addr) -> return (Native (unsafeCoerce# addr))
Nothing -> pprPanic "lookupNullaryCon" (ppr con)
@@ -637,29 +645,30 @@ lookupNative ce var =
Just e -> return (Native e)
Nothing -> do
-- try looking up in the object files.
- let lbl = (rdrNameToCLabel var "closure")
+ let lbl = (nameToCLabel var "closure")
m <- lookupSymbol lbl
case m of
- Just (A# addr) -> return (Native (unsafeCoerce# addr))
+ Just (A# addr)
+ -> do addCAF (unsafeCoerce# addr)
+ return (Native (unsafeCoerce# addr))
Nothing -> pprPanic "linkIExpr" (ppr var)
)
-- some VarI/VarP refer to top-level interpreted functions; we change
-- them into Natives here.
lookupVar ce f v =
- unsafeInterleaveIO (do
- case lookupFM ce (toRdrName v) of
- Nothing -> return (f v)
- Just e -> return (Native e)
+ unsafeInterleaveIO (
+ case lookupFM ce (getName v) of
+ Nothing -> return (f v)
+ Just e -> return (Native e)
)
-- HACK!!! ToDo: cleaner
-rdrNameToCLabel :: RdrName -> String{-suffix-} -> String
-rdrNameToCLabel rn suffix
- | isUnqual rn = pprPanic "rdrNameToCLabel" (ppr rn)
- | otherwise =
+nameToCLabel :: Name -> String{-suffix-} -> String
+nameToCLabel n suffix =
_UNPK_(moduleNameFS (rdrNameModule rn))
++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
+ where rn = toRdrName n
-- ---------------------------------------------------------------------------
-- The interpreter proper
@@ -1233,7 +1242,7 @@ make_constr_itbls cons
mk_dirret_itbl (dcon, conNo)
= mk_itbl dcon conNo mci_constr_entry
- mk_itbl :: DataCon -> Int -> Addr -> IO (RdrName,ItblPtr)
+ mk_itbl :: DataCon -> Int -> Addr -> IO (Name,ItblPtr)
mk_itbl dcon conNo entry_addr
= let (tot_wds, ptr_wds, _)
= mkVirtHeapOffsets typePrimRep (dataConRepArgTys dcon)
@@ -1268,7 +1277,7 @@ make_constr_itbls cons
putStrLn ("# ptrs of itbl is " ++ show ptrs)
putStrLn ("# nptrs of itbl is " ++ show nptrs)
poke addr itbl
- return (toRdrName dcon, addr `plusPtr` 8)
+ return (getName dcon, addr `plusPtr` 8)
byte :: Int -> Word32 -> Word32
diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs
index 16db45d417..5438b631ee 100644
--- a/ghc/compiler/main/DriverPipeline.hs
+++ b/ghc/compiler/main/DriverPipeline.hs
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.34 2000/11/21 14:34:50 simonmar Exp $
+-- $Id: DriverPipeline.hs,v 1.35 2000/11/24 17:09:52 simonmar Exp $
--
-- GHC Driver
--
@@ -777,11 +777,11 @@ compile ghci_mode summary source_unchanged old_iface hst hit pcs = do
init_driver_state <- readIORef v_InitDriverState
writeIORef v_Driver_state init_driver_state
- showPass init_dyn_flags (showSDoc (text "*** Compiling: "
- <+> ppr (name_of_summary summary)))
+ showPass init_dyn_flags
+ (showSDoc (text "Compiling" <+> ppr (name_of_summary summary)))
let verb = verbosity init_dyn_flags
- let location = ms_location summary
+ let location = ms_location summary
let input_fn = unJust "compile:hs" (ml_hs_file location)
let input_fnpp = unJust "compile:hspp" (ml_hspp_file location)
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index a9b0223c23..a0eacf3a27 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -6,7 +6,7 @@
\begin{code}
module HscMain ( HscResult(..), hscMain,
#ifdef GHCI
- hscExpr, hscTypeExpr,
+ hscExpr,
#endif
initPersistentCompilerState ) where
@@ -70,7 +70,7 @@ import Module ( Module, lookupModuleEnvByName )
import Monad ( when )
import Maybe ( isJust )
-import IO ( hPutStrLn, stderr )
+import IO
\end{code}
@@ -142,7 +142,8 @@ hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch
in return (HscNoRecomp pcs_ch bomb bomb)
| otherwise
= do {
- hPutStrLn stderr "compilation IS NOT required";
+ hPutStr stderr "compilation IS NOT required";
+ when (verbosity dflags /= 1) $ hPutStrLn stderr "";
-- CLOSURE
(pcs_cl, closure_errs, cl_hs_decls)
@@ -171,7 +172,10 @@ hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch
hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch
= do {
; when (verbosity dflags >= 1) $
- hPutStrLn stderr "compilation IS required";
+ hPutStr stderr "compilation IS required";
+ -- mode -v1 tries to keep everything on one line
+ when (verbosity dflags /= 1) $
+ hPutStrLn stderr "";
-- what target are we shooting for?
; let toInterp = dopt_HscLang dflags == HscInterpreted
@@ -393,17 +397,29 @@ hscExpr
-> PersistentCompilerState -- IN: persistent compiler state
-> Module -- Context for compiling
-> String -- The expression
- -> IO ( PersistentCompilerState, Maybe UnlinkedIExpr )
+ -> IO ( PersistentCompilerState,
+ Maybe (UnlinkedIExpr, PrintUnqualified, Type) )
hscExpr dflags hst hit pcs0 this_module expr
= do {
- -- parse, rename & typecheck the expression
- (pcs1, maybe_tc_result)
- <- hscExprFrontEnd dflags hst hit pcs0 this_module expr;
+ maybe_parsed <- hscParseExpr dflags expr;
+ case maybe_parsed of
+ Nothing -> return (pcs0, Nothing)
+ Just parsed_expr -> do {
+
+ -- Rename it
+ (pcs1, maybe_renamed_expr) <-
+ renameExpr dflags hit hst pcs0 this_module parsed_expr;
+ case maybe_renamed_expr of
+ Nothing -> return (pcs1, Nothing)
+ Just (print_unqual, rn_expr) -> do {
- case maybe_tc_result of {
- Nothing -> return (pcs1, Nothing);
- Just (print_unqual, tc_expr, ty) -> do {
+ -- Typecheck it
+ maybe_tc_return
+ <- typecheckExpr dflags pcs1 hst print_unqual this_module rn_expr;
+ case maybe_tc_return of {
+ Nothing -> return (pcs1, Nothing);
+ Just (pcs2, tc_expr, ty) -> do
-- if it isn't an IO-typed expression,
-- wrap "print" around it & recompile...
@@ -413,16 +429,21 @@ hscExpr dflags hst hit pcs0 this_module expr
};
if (not is_IO_type)
- then hscExpr dflags hst hit pcs1 this_module
- ("print (" ++ expr ++ ")")
+ then do (new_pcs, maybe_stuff)
+ <- hscExpr dflags hst hit pcs2 this_module
+ ("print (" ++ expr ++ ")")
+ case maybe_stuff of
+ Nothing -> return (new_pcs, maybe_stuff)
+ Just (expr, _, _) ->
+ return (new_pcs, Just (expr, print_unqual, ty))
else do
-- Desugar it
- ds_expr <- deSugarExpr dflags pcs1 hst this_module
+ ds_expr <- deSugarExpr dflags pcs2 hst this_module
print_unqual tc_expr;
-- Simplify it
- simpl_expr <- simplifyExpr dflags pcs1 hst ds_expr;
+ simpl_expr <- simplifyExpr dflags pcs2 hst ds_expr;
-- Convert to STG
stg_expr <- coreToStgExpr dflags simpl_expr;
@@ -432,56 +453,8 @@ hscExpr dflags hst hit pcs0 this_module expr
-- Convert to InterpSyn
unlinked_iexpr <- stgExprToInterpSyn dflags stg_expr;
- return (pcs1, Just unlinked_iexpr);
- }}}
-
-hscExprFrontEnd
- :: DynFlags
- -> HomeSymbolTable
- -> HomeIfaceTable
- -> PersistentCompilerState -- IN: persistent compiler state
- -> Module -- Context for compiling
- -> String -- The expression
- -> IO ( PersistentCompilerState,
- Maybe (PrintUnqualified,TypecheckedHsExpr,Type)
- )
-hscExprFrontEnd dflags hst hit pcs0 this_module expr
- = do { -- Parse it
- maybe_parsed <- hscParseExpr dflags expr;
- case maybe_parsed of
- Nothing -> return (pcs0, Nothing)
- Just parsed_expr -> do {
-
- -- Rename it
- (pcs1, maybe_renamed_expr) <-
- renameExpr dflags hit hst pcs0 this_module parsed_expr;
- case maybe_renamed_expr of
- Nothing -> return (pcs1, Nothing)
- Just (print_unqual, rn_expr) -> do {
-
- -- Typecheck it
- maybe_tc_return
- <- typecheckExpr dflags pcs1 hst print_unqual this_module rn_expr;
- case maybe_tc_return of
- Nothing -> return (pcs1, Nothing)
- Just (pcs2, tc_expr, ty) ->
- return (pcs2, Just (print_unqual, tc_expr, ty))
- }}}
-
-hscTypeExpr
- :: DynFlags
- -> HomeSymbolTable
- -> HomeIfaceTable
- -> PersistentCompilerState -- IN: persistent compiler state
- -> Module -- Context for compiling
- -> String -- The expression
- -> IO (PersistentCompilerState, Maybe (PrintUnqualified, Type))
-hscTypeExpr dflags hst hit pcs0 this_module expr
- = do (pcs1, maybe_tc_result)
- <- hscExprFrontEnd dflags hst hit pcs0 this_module expr
- case maybe_tc_result of
- Nothing -> return (pcs1, Nothing)
- Just (print_unqual,_,ty) -> return (pcs1, Just (print_unqual,ty))
+ return (pcs2, Just (unlinked_iexpr, print_unqual, ty));
+ }}}}
hscParseExpr :: DynFlags -> String -> IO (Maybe RdrNameHsExpr)
hscParseExpr dflags str
diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index 6f7be2f68d..a7adcdd16d 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.34 2000/11/24 17:02:02 simonpj Exp $
+-- $Id: Main.hs,v 1.35 2000/11/24 17:09:52 simonmar Exp $
--
-- GHC Driver program
--
@@ -302,11 +302,10 @@ beginInteractive = throwDyn (OtherError "not build for interactive use")
#else
beginInteractive mods
= do state <- cmInit Interactive
- (state', ok, ms)
- <- case mods of
- [] -> return (state, True, [])
- [mod] -> cmLoadModule state mod
+ let mod = case mods of
+ [] -> Nothing
+ [mod] -> Just mod
_ -> throwDyn (UsageError
"only one module allowed with --interactive")
- interactiveUI state' ms
+ interactiveUI state mod
#endif
View Lorry Controller Status