----------------------------------------------------------------------------- -- -- GHCi Interactive debugging commands -- -- Pepe Iborra (supported by Google SoC) 2006 -- -- ToDo: lots of violation of layering here. This module should -- decide whether it is above the GHC API (import GHC and nothing -- else) or below it. -- ----------------------------------------------------------------------------- module GHC.Runtime.Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where import GHC.Prelude import GHC import GHC.Data.List.Infinite (Infinite (..)) import qualified GHC.Data.List.Infinite as Inf import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Driver.Monad import GHC.Driver.Env import GHC.Linker.Loader import GHC.Runtime.Heap.Inspect import GHC.Runtime.Interpreter import GHC.Runtime.Context import GHC.Iface.Syntax ( showToHeader ) import GHC.Iface.Env ( newInteractiveBinder ) import GHC.Core.Type import GHC.Core.TyCo.Tidy( tidyOpenType ) import GHC.Utils.Outputable import GHC.Utils.Error import GHC.Utils.Monad import GHC.Utils.Exception import GHC.Utils.Logger import GHC.Types.Id import GHC.Types.Id.Make (ghcPrimIds) import GHC.Types.Name import GHC.Types.Var hiding ( varName ) import GHC.Types.Var.Set import GHC.Types.Unique.Set import GHC.Types.TyThing.Ppr import GHC.Types.TyThing import Control.Monad import Control.Monad.Catch as MC import Data.List ( partition ) import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.IORef ------------------------------------- -- | The :print & friends commands ------------------------------------- pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m () pprintClosureCommand bindThings force str = do tythings <- (catMaybes . concatMap NE.toList) `liftM` mapM (\w -> GHC.parseName w >>= mapM GHC.lookupName) (words str) -- Sort out good and bad tythings for :print and friends let (pprintables, unpprintables) = partition can_pprint tythings -- Obtain the terms and the recovered type information let ids = [id | AnId id <- pprintables] (subst, terms) <- mapAccumLM go emptySubst ids -- Apply the substitutions obtained after recovering the types modifySession $ \hsc_env -> hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst} -- Finally, print the Results docterms <- mapM showTerm terms let sdocTerms = zipWith (\id docterm -> ppr id <+> char '=' <+> docterm) ids docterms printSDocs $ (no_pprint <$> unpprintables) ++ sdocTerms where -- Check whether a TyThing can be processed by :print and friends. -- Take only Ids, exclude pseudoops, they don't have any HValues. can_pprint :: TyThing -> Bool -- #19394 can_pprint (AnId x) | x `notElem` ghcPrimIds = True | otherwise = False can_pprint _ = False -- Create a short message for a TyThing, that cannot processed by :print no_pprint :: TyThing -> SDoc no_pprint tything = ppr tything <+> text "is not eligible for the :print, :sprint or :force commands." -- Helper to print out the results of :print and friends printSDocs :: GhcMonad m => [SDoc] -> m () printSDocs sdocs = do logger <- getLogger name_ppr_ctx <- GHC.getNamePprCtx liftIO $ printOutputForUser logger name_ppr_ctx $ vcat sdocs -- Do the obtainTerm--bindSuspensions-computeSubstitution dance go :: GhcMonad m => Subst -> Id -> m (Subst, Term) go subst id = do let id' = updateIdTypeAndMult (substTy subst) id id_ty' = idType id' term_ <- GHC.obtainTermFromId maxBound force id' term <- tidyTermTyVars term_ term' <- if bindThings then bindSuspensions term else return term -- Before leaving, we compare the type obtained to see if it's more specific -- Then, we extract a substitution, -- mapping the old tyvars to the reconstructed types. let reconstructed_type = termType term hsc_env <- getSession case (improveRTTIType hsc_env id_ty' reconstructed_type) of Nothing -> return (subst, term') Just subst' -> do { logger <- getLogger ; liftIO $ putDumpFileMaybe logger Opt_D_dump_rtti "RTTI" FormatText (fsep $ [text "RTTI Improvement for", ppr id, text "old substitution:" , ppr subst, text "new substitution:" , ppr subst']) ; return (subst `unionSubst` subst', term')} tidyTermTyVars :: GhcMonad m => Term -> m Term tidyTermTyVars t = withSession $ \hsc_env -> do let env_tvs = tyThingsTyCoVars $ ic_tythings $ hsc_IC hsc_env my_tvs = termTyCoVars t tvs = env_tvs `minusVarSet` my_tvs tyvarOccName = nameOccName . tyVarName tidyEnv = (initTidyOccEnv (map tyvarOccName (nonDetEltsUniqSet tvs)) -- It's OK to use nonDetEltsUniqSet here because initTidyOccEnv -- forgets the ordering immediately by creating an env , getUniqSet $ env_tvs `intersectVarSet` my_tvs) return $ mapTermType (tidyOpenType tidyEnv) t -- | Give names, and bind in the interactive environment, to all the suspensions -- included (inductively) in a term bindSuspensions :: GhcMonad m => Term -> m Term bindSuspensions t = do hsc_env <- getSession inScope <- GHC.getBindings let ictxt = hsc_IC hsc_env prefix = "_t" alreadyUsedNames = map (occNameString . nameOccName . getName) inScope availNames = (Inf.filter (`notElem` alreadyUsedNames) . fmap ((prefix++) . show)) (Inf.enumFrom (1::Int)) availNames_var <- liftIO $ newIORef availNames (t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t let (names, tys, fhvs) = unzip3 stuff let ids = [ mkVanillaGlobal name ty | (name,ty) <- zip names tys] new_ic = extendInteractiveContextWithIds ictxt ids interp = hscInterp hsc_env liftIO $ extendLoadedEnv interp (zip names fhvs) setSession hsc_env {hsc_IC = new_ic } return t' where -- Processing suspensions. Give names and collect info nameSuspensionsAndGetInfos :: HscEnv -> IORef (Infinite String) -> TermFold (IO (Term, [(Name,Type,ForeignHValue)])) nameSuspensionsAndGetInfos hsc_env freeNames = TermFold { fSuspension = doSuspension hsc_env freeNames , fTerm = \ty dc v tt -> do tt' <- sequence tt let (terms,names) = unzip tt' return (Term ty dc v terms, concat names) , fPrim = \ty n ->return (Prim ty n,[]) , fNewtypeWrap = \ty dc t -> do (term, names) <- t return (NewtypeWrap ty dc term, names) , fRefWrap = \ty t -> do (term, names) <- t return (RefWrap ty term, names) } doSuspension hsc_env freeNames ct ty hval _name ipe = do name <- atomicModifyIORef' freeNames (\(Inf x xs)->(xs, x)) n <- newGrimName hsc_env name return (Suspension ct ty hval (Just n) ipe, [(n,ty,hval)]) -- A custom Term printer to enable the use of Show instances showTerm :: GhcMonad m => Term -> m SDoc showTerm term = do dflags <- GHC.getSessionDynFlags if gopt Opt_PrintEvldWithShow dflags then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term else cPprTerm cPprTermBase term where cPprShowable prec t@Term{ty=ty, val=fhv} = if not (isFullyEvaluatedTerm t) then return Nothing else do let set_session = do hsc_env <- getSession (new_env, bname) <- bindToFreshName hsc_env ty "showme" setSession new_env -- this disables logging of errors let noop_log _ _ _ _ = return () pushLogHookM (const noop_log) return (hsc_env, bname) reset_session (old_env,_) = setSession old_env MC.bracket set_session reset_session $ \(_,bname) -> do hsc_env <- getSession dflags <- GHC.getSessionDynFlags let expr = "Prelude.return (Prelude.show " ++ showPpr dflags bname ++ ") :: Prelude.IO Prelude.String" interp = hscInterp hsc_env txt_ <- withExtendedLoadedEnv interp [(bname, fhv)] (GHC.compileExprRemote expr) let myprec = 10 -- application precedence. TODO Infix constructors txt <- liftIO $ evalString interp txt_ if not (null txt) then return $ Just $ cparen (prec >= myprec && needsParens txt) (text txt) else return Nothing cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = cPprShowable prec t{ty=new_ty} cPprShowable _ _ = return Nothing needsParens ('"':_) = False -- some simple heuristics to see whether parens -- are redundant in an arbitrary Show output needsParens ('(':_) = False needsParens txt = ' ' `elem` txt bindToFreshName hsc_env ty userName = do name <- newGrimName hsc_env userName let id = mkVanillaGlobal name ty new_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) [id] return (hsc_env {hsc_IC = new_ic }, name) -- Create new uniques and give them sequentially numbered names newGrimName :: MonadIO m => HscEnv -> String -> m Name newGrimName hsc_env userName = liftIO (newInteractiveBinder hsc_env occ noSrcSpan) where occ = mkOccName varName userName pprTypeAndContents :: GhcMonad m => Id -> m SDoc pprTypeAndContents id = do dflags <- GHC.getSessionDynFlags let pcontents = gopt Opt_PrintBindContents dflags pprdId = (pprTyThing showToHeader . AnId) id if pcontents then do let depthBound = 100 -- If the value is an exception, make sure we catch it and -- show the exception, rather than propagating the exception out. e_term <- MC.try $ GHC.obtainTermFromId depthBound False id docs_term <- case e_term of Right term -> showTerm term Left exn -> return (text "*** Exception:" <+> text (show (exn :: SomeException))) return $ pprdId <+> equals <+> docs_term else return pprdId