X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=f88fe44995de6d6781bbae836b5f516371c835f0;hb=131320a1b79d965540449927b640ab037fb7a13a;hp=598341ad4c071bed3b87ecb340733788e16a769b;hpb=6fb850636267af7a0a52322c0a670963034ae784;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 598341a..f88fe44 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -1,3 +1,6 @@ +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- -- @@ -11,12 +14,13 @@ module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where #include "HsVersions.h" -import GhciMonad +import qualified GhciMonad +import GhciMonad hiding (runStmt) import GhciTags import Debugger -- The GHC interface -import qualified GHC +import qualified GHC hiding (resume, runStmt) import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), Module, ModuleName, TyThing(..), Phase, BreakIndex, SrcSpan, Resume, SingleStep ) @@ -37,6 +41,7 @@ import Name import SrcLoc -- Other random utilities +import ErrUtils import Digraph import BasicTypes hiding (isTopLevel) import Panic hiding (showException) @@ -228,6 +233,9 @@ helpText = " :force print , forcing unevaluated parts\n" ++ " :forward go forward in the history (after :back)\n" ++ " :history [] after :trace, show the execution history\n" ++ + " :list show the source code around current breakpoint\n" ++ + " :list identifier show the source code for \n" ++ + " :list [] show the source code around line number \n" ++ " :print [ ...] prints a value without forcing its computation\n" ++ " :sprint [ ...] simplifed version of :print\n" ++ " :step single-step after stopping at a breakpoint\n"++ @@ -335,6 +343,8 @@ interactiveUI session srcs maybe_exprs = do default_editor <- findEditor + cwd <- getCurrentDirectory + startGHCi (runGHCi srcs maybe_exprs) GHCiState{ progname = "", args = [], @@ -349,7 +359,9 @@ interactiveUI session srcs maybe_exprs = do tickarrays = emptyModuleEnv, last_command = Nothing, cmdqueue = [], - remembered_ctx = [] + remembered_ctx = [], + virtual_path = cwd, + ghc_e = isJust maybe_exprs } #ifdef USE_EDITLINE @@ -446,12 +458,8 @@ runGHCi paths maybe_exprs = do -- current progname in the exception text: -- : io $ withProgName (progname st) - -- The "fast exit" part just calls exit() - -- directly instead of doing an orderly - -- runtime shutdown, otherwise the main - -- GHCi thread will complain about being - -- interrupted. - $ topHandlerFastExit e + -- this used to be topHandlerFastExit, see #2228 + $ topHandler e runCommands' handle (return Nothing) -- and finally, exit @@ -685,13 +693,9 @@ runStmt stmt step | null (filter (not.isSpace) stmt) = return False | ["import", mod] <- words stmt = keepGoing setContext ('+':mod) | otherwise - = do st <- getGHCiState - session <- getSession - result <- io $ withProgName (progname st) $ withArgs (args st) $ - GHC.runStmt session stmt step + = do result <- GhciMonad.runStmt stmt step afterRunStmt (const True) result - --afterRunStmt :: GHC.RunResult -> GHCi Bool -- False <=> the statement failed to compile afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool @@ -706,7 +710,7 @@ afterRunStmt step_here run_result = do GHC.RunBreak _ names mb_info | isNothing mb_info || step_here (GHC.resumeSpan $ head resumes) -> do - printForUser $ ptext SLIT("Stopped at") <+> + printForUser $ ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan $ head resumes) -- printTypeOfNames session names let namesSorted = sortBy compareNames names @@ -719,14 +723,14 @@ afterRunStmt step_here run_result = do st <- getGHCiState enqueueCommands [stop st] return () - | otherwise -> io(GHC.resume session GHC.SingleStep) >>= + | otherwise -> resume GHC.SingleStep >>= afterRunStmt step_here >> return () _ -> return () flushInterpBuffers io installSignalHandlers b <- isOptionSet RevertCAFs - io (when b revertCAFs) + when b revertCAFs return (case run_result of GHC.RunOk _ -> True; _ -> False) @@ -896,7 +900,7 @@ doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++ addModule :: [FilePath] -> GHCi () addModule files = do - io (revertCAFs) -- always revert CAFs on load/add. + revertCAFs -- always revert CAFs on load/add. files <- mapM expandPath files targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files session <- getSession @@ -1095,7 +1099,7 @@ doLoad session retain_context prev_context howmuch = do afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi () afterLoad ok session retain_context prev_context = do - io (revertCAFs) -- always revert CAFs on load. + revertCAFs -- always revert CAFs on load. discardTickArrays loaded_mod_summaries <- getLoadedModules session let loaded_mods = map GHC.ms_mod loaded_mod_summaries @@ -1405,13 +1409,13 @@ setCmd "" vcat (text "other dynamic, non-language, flag settings:" :map (flagSetting dflags) nonLanguageDynFlags) )) - where flagSetting dflags (str,f) + where flagSetting dflags (str, f, _) | dopt f dflags = text " " <> text "-f" <> text str | otherwise = text " " <> text "-fno-" <> text str - (ghciFlags,others) = partition (\(_,f)->f `elem` flags) + (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags) DynFlags.fFlags - nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags) - others + nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions) + others flags = [Opt_PrintExplicitForalls ,Opt_PrintBindResult ,Opt_BreakOnException @@ -1487,7 +1491,8 @@ newDynFlags :: [String] -> GHCi () newDynFlags minus_opts = do dflags <- getDynFlags let pkg_flags = packageFlags dflags - (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts + (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags minus_opts + io $ handleFlagWarnings dflags' warns if (not (null leftovers)) then throwDyn (CmdLineError ("unrecognised flags: " ++ @@ -1623,8 +1628,8 @@ showContext = do printForUser $ vcat (map pp_resume (reverse resumes)) where pp_resume resume = - ptext SLIT("--> ") <> text (GHC.resumeStmt resume) - $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume)) + ptext (sLit "--> ") <> text (GHC.resumeStmt resume) + $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume)) showPackages :: GHCi () showPackages = do @@ -1635,7 +1640,8 @@ showPackages = do pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags io $ putStrLn $ showSDoc $ vcat $ text "packages currently loaded:" - : map (nest 2 . text . packageIdString) pkg_ids + : map (nest 2 . text . packageIdString) + (sortBy (compare `on` packageIdFS) pkg_ids) where showFlag (ExposePackage p) = text $ " -package " ++ p showFlag (HidePackage p) = text $ " -hide-package " ++ p showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p @@ -1645,7 +1651,7 @@ showLanguages = do dflags <- getDynFlags io $ putStrLn $ showSDoc $ vcat $ text "active language flags:" : - [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags] + [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags] -- ----------------------------------------------------------------------------- -- Completion @@ -1686,7 +1692,7 @@ completeWord w start end = do (s,r') = span isBreak r in (n,w):words' isBreak (n+length w+length s) r' -- In a Haskell expression we want to parse 'a-b' as three words - -- where a compiler flag (ie. -fno-monomorphism-restriction) should + -- where a compiler flag (e.g. -ddump-simpl) should -- only be a single word. selectWord [] = (0,w) selectWord ((offset,x):xs) @@ -1946,8 +1952,7 @@ continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion -- doContinue :: SingleStep -> GHCi () doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () doContinue pred step = do - session <- getSession - runResult <- io $ GHC.resume session step + runResult <- resume step afterRunStmt pred runResult return () @@ -2011,7 +2016,7 @@ backCmd :: String -> GHCi () backCmd = noArgs $ do s <- getSession (names, _, span) <- io $ GHC.back s - printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span + printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span printTypeOfNames s names -- run the command set with ":set stop " st <- getGHCiState @@ -2022,8 +2027,8 @@ forwardCmd = noArgs $ do s <- getSession (names, ix, span) <- io $ GHC.forward s printForUser $ (if (ix == 0) - then ptext SLIT("Stopped at") - else ptext SLIT("Logged breakpoint at")) <+> ppr span + then ptext (sLit "Stopped at") + else ptext (sLit "Logged breakpoint at")) <+> ppr span printTypeOfNames s names -- run the command set with ":set stop " st <- getGHCiState