X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FDebugger.hs;h=9f0684c7f4e7f12d85e0665684b9d39b81356d85;hb=5cceab60a792e0d05a544135d1d65b1255645970;hp=99b14c9566a6a18f40a11be9eedc802a280dae35;hpb=8b08c15b8ace5a76e341939081fbb6ad2736ddd1;p=ghc-hetmet.git diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 99b14c9..9f0684c 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -38,12 +38,12 @@ import ErrUtils import FastString import SrcLoc import Util +import Maybes import Control.Exception import Control.Monad import qualified Data.Map as Map import Data.Array.Unboxed -import Data.Traversable ( traverse ) import Data.Typeable ( Typeable ) import Data.Maybe import Data.IORef @@ -77,9 +77,9 @@ pprintClosureCommand bindThings force str = do -- Give names to suspensions and bind them in the local env mb_terms' <- if bindThings - then io$ mapM (traverse (bindSuspensions cms)) mb_terms + then io$ mapM (fmapMMaybe (bindSuspensions cms)) mb_terms else return mb_terms - ppr_terms <- io$ mapM (traverse (printTerm cms)) mb_terms' + ppr_terms <- io$ mapM (fmapMMaybe (printTerm cms)) mb_terms' let docs = [ ppr id <+> char '=' <+> t | (Just t,id) <- zip ppr_terms ids] unqual <- io$ GHC.getPrintUnqual cms io . putStrLn . showSDocForUser unqual $ Outputable.vcat docs @@ -108,7 +108,6 @@ pprintClosureCommand bindThings force str = do , substFiltered <- filter (not.isTyVarTy) . varEnvElts . getTvSubstEnv $ subst , not . null $ substFiltered , all (flip notElemTvSubst subst) ty_vars --- , pprTrace "subst" (ppr subst) True = True | otherwise = False where bindOnlyTy1 tyv | tyv `elem` ty_vars = AvoidMe @@ -261,7 +260,6 @@ stripUnknowns :: [Name] -> Id -> Id stripUnknowns names id = setIdType id . sigmaType . fst . go names . idType $ id where - sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty go tyvarsNames@(v:vv) ty | Just (ty1,ty2) <- splitFunTy_maybe ty = let (ty1',vv') = go tyvarsNames ty1 @@ -298,13 +296,22 @@ stripUnknowns _ id = id ----------------------------- -- | The :breakpoint command ----------------------------- -bkptOptions :: String -> GHCi () +bkptOptions :: String -> GHCi Bool +bkptOptions "continue" = -- We want to quit if in an inferior session + liftM not isTopLevel +bkptOptions "stop" = do + inside_break <- liftM not isTopLevel + when inside_break $ throwDyn StopChildSession + return False + bkptOptions cmd = do dflags <- getDynFlags bt <- getBkptTable - bkptOptions' (words cmd) bt + sess <- getSession + bkptOptions' sess (words cmd) bt + return False where - bkptOptions' ["list"] bt = do + bkptOptions' _ ["list"] bt = do let msgs = [ ppr mod <+> colon <+> ppr coords | (mod,site) <- btList bt , let coords = getSiteCoords bt mod site] @@ -314,11 +321,7 @@ bkptOptions cmd = do else vcat num_msgs io$ putStrLn msg - bkptOptions' ["stop"] bt = do - inside_break <- liftM not isTopLevel - when inside_break $ throwDyn StopChildSession - - bkptOptions' ("add":cmds) bt + bkptOptions' s ("add":cmds) bt | [mod_name,line]<- cmds , [(lineNum,[])] <- reads line = handleAdd mod_name $ (\mod->addBkptByLine mod lineNum) @@ -330,17 +333,15 @@ bkptOptions cmd = do "syntax: :breakpoint add Module line [col]" where handleAdd mod_name f = do - sess <- getSession - dflags <- getDynFlags - mod <- io$ GHC.findModule sess (GHC.mkModuleName mod_name) Nothing - ghciHandleDyn (handleBkptEx mod) $ + mod <- io$ GHC.findModule s (GHC.mkModuleName mod_name) Nothing + ghciHandleDyn (handleBkptEx s mod) $ case f mod bt of (newTable, site) -> do setBkptTable newTable io (putStrLn ("Breakpoint set at " ++ show (getSiteCoords newTable mod site))) - bkptOptions' ("del":cmds) bt + bkptOptions' s ("del":cmds) bt | [i'] <- cmds , [(i,[])] <- reads i' , bkpts <- btList bt @@ -366,20 +367,29 @@ bkptOptions cmd = do "syntax: :breakpoint del (breakpoint # | Module line [col])" where delMsg = "Breakpoint deleted" - handleDel mod f = ghciHandleDyn (handleBkptEx mod) $ do - modifyBkptTable f - newTable <- getBkptTable - sess <- getSession - dflags <- getDynFlags - io$ putStrLn delMsg - - bkptOptions' _ _ = throwDyn $ CmdLineError $ - "syntax: :breakpoint (list|stop|add|del)" - - handleBkptEx :: Module -> Debugger.BkptException -> a - handleBkptEx _ NoBkptFound = error "No suitable breakpoint site found" --TODO Automatically add to the next suitable line - handleBkptEx _ NotNeeded = error "Nothing to do" - handleBkptEx m NotHandled = error$ "Module " ++ showSDoc (ppr m) ++ " was not loaded under debugging mode. Enable debugging mode and reload it" + handleDel mod f = ghciHandleDyn (handleBkptEx s mod) + (modifyBkptTable f >> io (putStrLn delMsg)) + + bkptOptions' _ _ _ = throwDyn $ CmdLineError $ + "syntax: :breakpoint (list|continue|stop|add|del)" + +-- Error messages +-- handleBkptEx :: Session -> Module -> Debugger.BkptException -> a + handleBkptEx _ _ NoBkptFound = error "No suitable breakpoint site found" + -- ^ TODO Instead of complaining, set a bkpt in the next suitable line + handleBkptEx _ _ NotNeeded = error "Nothing to do" + handleBkptEx s m NotHandled = io$ + findModSummary m >>= \mod_summary -> + isModuleInterpreted s mod_summary >>= \it -> + if it + then error$ "Module " ++ showSDoc (ppr m) ++ " was not loaded under debugging mode.\n" + ++ "Enable debugging mode with -fdebugging (and reload your module)" + else error$ "Module " ++ showSDoc (ppr m) ++ " was loaded in compiled (.o) mode.\n" + ++ "You must load a module in interpreted mode and with -fdebugging on to debug it." + where findModSummary m = getModuleGraph s >>= \mod_graph -> + case [ modsum | modsum <- mod_graph + , ms_mod modsum == m ] of + [modsum] -> return modsum ------------------------- -- Breakpoint Tables @@ -510,8 +520,7 @@ getSiteCoords bt a site , s == site ] -- addModule is dumb and inefficient, but it does the job ---addModule fn siteCoords _ | trace ("addModule: " ++ moduleString (unsafeCoerce# fn) ++ " - " ++ show siteCoords) False = undefined -addModule a [] bt = bt +addModule a [] bt = bt {sites = Map.insert a [] (sites bt)} addModule a siteCoords bt | nrows <- maximum$ [i | (_,(i,j)) <- siteCoords ] , sitesByRow <- [ [(s,c) | (s,(r,c)) <- siteCoords, r==i] @@ -525,7 +534,7 @@ isBkptEnabled bt (a,site) | Just bkpts <- bkptsOf bt a , inRange (bounds bkpts) site = bkpts ! site - | otherwise = throwDyn NotHandled -- This is an error + | otherwise = panic "unexpected condition: I don't know that breakpoint site" ----------------- -- Other stuff @@ -533,7 +542,8 @@ isBkptEnabled bt (a,site) refreshBkptTable :: [ModSummary] -> GHCi () refreshBkptTable [] = return () refreshBkptTable (ms:mod_sums) = do - sess <- getSession + sess <- getSession + isDebugging <- io(isDebuggingM sess) when isDebugging $ do old_table <- getBkptTable new_table <- addModuleGHC sess old_table (GHC.ms_mod ms) @@ -548,7 +558,10 @@ refreshBkptTable (ms:mod_sums) = do text " breakpoints") return$ addModule mod sites bt #if defined(GHCI) && defined(DEBUGGER) - isDebugging = Opt_Debugging `elem` flags (GHC.ms_hspp_opts ms) + isDebuggingM sess = isModuleInterpreted sess ms >>= \isInterpreted -> + return (Opt_Debugging `elem` dflags && target == HscInterpreted && isInterpreted) + dflags = flags (GHC.ms_hspp_opts ms) + target = hscTarget (GHC.ms_hspp_opts ms) #else - isDebugging = False -#endif \ No newline at end of file + isDebuggingM _ = return False +#endif