Commit 8fe9b1af authored by simonmar's avatar simonmar
Browse files

[project @ 2000-11-24 17:09:52 by simonmar]

- Bug fixes to the interpreter.  Now much more stable - it hasn't crashed
  all day.

- Many improvements to the user interface (eg. :set +t and :set +s
  work just like Hugs).

- Several wibbles & message improvements: the interpreter now informs you
  when it's loading the object code for a given module.
parent 83eef621
......@@ -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) <-
......
......@@ -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]
......
-----------------------------------------------------------------------------
-- $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")))
......@@ -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
-----------------------------------------------------------------------------
......
......@@ -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 ;
......@@ -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