X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FDebugger.hs;h=be27bf78f1de2923265f072c87bc25896d8fed57;hb=64496ad6ff9164151381d11d223294bde1859211;hp=6248e0c01519e316891d8467cf286c96a85c1e31;hpb=9004e883504aa93055a9fbdebfb21753e2454ca6;p=ghc-hetmet.git diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 6248e0c..be27bf7 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -66,8 +66,8 @@ pprintClosureCommand bindThings force str = do uniques <- liftM uniqsFromSupply (mkSplitUniqSupply 'q') return$ map (\u-> (mkSysTvName u (mkFastString "a"))) uniques mb_ids <- io$ mapM (cleanUp cms newvarsNames) (words str) - new_ids <- mapM (io . go cms) (catMaybes mb_ids) - io$ updateIds cms new_ids + mb_new_ids <- mapM (io . go cms) (catMaybes mb_ids) + io$ updateIds cms (catMaybes mb_new_ids) where -- Find the Id, clean up 'Unknowns' cleanUp :: Session -> [Name] -> String -> IO (Maybe Id) @@ -78,22 +78,23 @@ pprintClosureCommand bindThings force str = do -- Do the obtainTerm--bindSuspensions-refineIdType dance -- Warning! This function got a good deal of side-effects - go :: Session -> Id -> IO Id + go :: Session -> Id -> IO (Maybe Id) go cms id = do - Just term <- obtainTerm cms force id - term' <- if not bindThings then return term - else bindSuspensions cms term - showterm <- pprTerm cms term' - unqual <- GHC.getPrintUnqual cms - let showSDocForUserOneLine unqual doc = - showDocWith LeftMode (doc (mkErrStyle unqual)) - (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm) + mb_term <- obtainTerm cms force id + maybe (return Nothing) `flip` mb_term $ \term -> do + term' <- if not bindThings then return term + else bindSuspensions cms term + showterm <- pprTerm cms term' + unqual <- GHC.getPrintUnqual cms + let showSDocForUserOneLine unqual doc = + showDocWith LeftMode (doc (mkErrStyle unqual)) + (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm) -- Before leaving, we compare the type obtained to see if it's more specific -- Note how we need the Unknown-clear type returned by obtainTerm - let Just reconstructedType = termType term - new_type <- instantiateTyVarsToUnknown cms - (mostSpecificType (idType id) reconstructedType) - return (setIdType id new_type) + let Just reconstructedType = termType term + new_type <- instantiateTyVarsToUnknown cms + (mostSpecificType (idType id) reconstructedType) + return . Just $ setIdType id new_type updateIds :: Session -> [Id] -> IO () updateIds (Session ref) new_ids = do @@ -265,7 +266,7 @@ instantiateTyVarsToUnknown cms ty -- | The inverse function. Strip the GHC.Base.Unknowns in the type of the id, they correspond to tyvars. The caller must provide an infinite list of fresh names stripUnknowns :: [Name] -> Id -> Id -stripUnknowns names id = setIdType id . sigmaType . fst . go names . idType +stripUnknowns names id = setIdType id . fst . go names . idType $ id where go tyvarsNames@(v:vv) ty @@ -330,24 +331,33 @@ bkptOptions cmd = do io$ putStrLn msg bkptOptions' s ("add":cmds) bt + | [line] <- cmds + , [(lineNum,[])] <- reads line + = do (toplevel,_) <- io$ GHC.getContext s + case toplevel of + (m:_) -> handleAdd (\mod->addBkptByLine mod lineNum) m + [] -> throwDyn $ CmdLineError $ "No module loaded in debugging mode" + | [mod_name,line]<- cmds , [(lineNum,[])] <- reads line - = handleAdd mod_name $ (\mod->addBkptByLine mod lineNum) + = io(GHC.findModule s (GHC.mkModuleName mod_name) Nothing) >>= + handleAdd (\mod->addBkptByLine mod lineNum) | [mod_name,line,col] <- cmds - = handleAdd mod_name $ (\mod->addBkptByCoord mod (read line, read col)) + = io(GHC.findModule s (GHC.mkModuleName mod_name) Nothing) >>= + handleAdd (\mod->addBkptByCoord mod (read line, read col)) | otherwise = throwDyn $ CmdLineError $ "syntax: :breakpoint add Module line [col]" where - handleAdd mod_name f = do - mod <- io$ GHC.findModule s (GHC.mkModuleName mod_name) Nothing + handleAdd f mod = either (handleBkptEx s mod) (\(newTable, site) -> do - setBkptTable newTable - io (putStrLn ("Breakpoint set at " ++ - show (getSiteCoords newTable mod site)))) + setBkptTable newTable + let (x,y) = getSiteCoords newTable mod site + io (putStrLn ("Breakpoint set at " ++ showSDoc (ppr mod) + ++ ':' : show x ++ ':' : show y))) (f mod bt) bkptOptions' s ("del":cmds) bt @@ -373,31 +383,28 @@ bkptOptions cmd = do = handleDel mod $ delBkptByCoord mod (lineNum, colNum) | otherwise = throwDyn $ CmdLineError $ - "syntax: :breakpoint del (breakpoint # | Module line [col])" + "syntax: :breakpoint del (breakpoint # | [Module] line [col])" where delMsg = "Breakpoint deleted" handleDel mod f = either (handleBkptEx s mod) (\newtable-> setBkptTable newtable >> io (putStrLn delMsg)) (f bt) - bkptOptions' _ _ _ = throwDyn $ CmdLineError $ "syntax: :breakpoint (list|continue|stop|add|del)" -- Error messages -- handleBkptEx :: Session -> Module -> Debugger.BkptException -> a - handleBkptEx s m NotHandled = io$ - findModSummary m >>= \mod_summary -> - isModuleInterpreted s mod_summary >>= \it -> - if it + handleBkptEx s m NotHandled = io$ do + isInterpreted <- findModSummary m >>= isModuleInterpreted s + if isInterpreted 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 + where findModSummary m = do + mod_graph <- getModuleGraph s + return$ head [ modsum | modsum <- mod_graph, ms_mod modsum == m] handleBkptEx _ _ e = error (show e) -------------------------