compiler/ghci/Debugger.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- GHCi Interactive debugging commands
   4 --
   5 -- Pepe Iborra (supported by Google SoC) 2006
   6 --
   7 -- ToDo: lots of violation of layering here.  This module should
   8 -- decide whether it is above the GHC API (import GHC and nothing
   9 -- else) or below it.
  10 --
  11 -----------------------------------------------------------------------------
  12
  13 module Debugger (pprintClosureCommand) where
  14
  15 import Linker
  16 import RtClosureInspect
  17
  18 import HscTypes
  19 import IdInfo
  20 --import Id
  21 import Name
  22 import Var hiding ( varName )
  23 import VarSet
  24 import VarEnv
  25 import Name
  26 import UniqSupply
  27 import Type
  28 import TcType
  29 import TcGadt
  30 import GHC
  31 import GhciMonad
  32 import InteractiveEval
  33 import Outputable
  34 import Pretty                    ( Mode(..), showDocWith )
  35 import FastString
  36 import SrcLoc
  37
  38 import Control.Exception
  39 import Control.Monad
  40 import Data.List
  41 import Data.Maybe
  42 import Data.IORef
  43
  44 import System.IO
  45 import GHC.Exts
  46
  47 #include "HsVersions.h"
  48 -------------------------------------
  49 -- | The :print & friends commands
  50 -------------------------------------
  51 pprintClosureCommand :: Session -> Bool -> Bool -> String -> IO ()
  52 pprintClosureCommand session bindThings force str = do
  53   tythings <- (catMaybes . concat) `liftM`
  54                  mapM (\w -> GHC.parseName session w >>=
  55                                 mapM (GHC.lookupName session))
  56                       (words str)
  57   substs <- catMaybes `liftM` mapM (go session)
  58                                    [id | AnId id <- tythings]
  59   modifySession session $ \hsc_env ->
  60          hsc_env{hsc_IC = foldr (flip substInteractiveContext)
  61                                 (hsc_IC hsc_env)
  62                                 (map skolemiseSubst substs)}
  63  where
  64
  65    -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
  66    go :: Session -> Id -> IO (Maybe TvSubst)
  67    go cms id = do
  68        term_    <- withSession cms $ \hsc_env -> obtainTerm hsc_env force id
  69        term     <- tidyTermTyVars cms term_
  70        term'    <- if not bindThings then return term
  71                      else bindSuspensions cms term
  72        showterm <- printTerm cms term'
  73        unqual   <- GHC.getPrintUnqual cms
  74        let showSDocForUserOneLine unqual doc =
  75                showDocWith LeftMode (doc (mkErrStyle unqual))
  76        (putStrLn . showSDocForUserOneLine unqual)
  77                                    (ppr id <+> char '=' <+> showterm)
  78      -- Before leaving, we compare the type obtained to see if it's more specific
  79      --  Then, we extract a substitution,
  80      --  mapping the old tyvars to the reconstructed types.
  81        let Just reconstructed_type = termType term
  82            mb_subst = computeRTTIsubst (idType id) (reconstructed_type)
  83
  84        ASSERT2 (isJust mb_subst, ppr reconstructed_type $$ (ppr$ idType id))
  85         return mb_subst
  86
  87    tidyTermTyVars :: Session -> Term -> IO Term
  88    tidyTermTyVars (Session ref) t = do
  89      hsc_env <- readIORef ref
  90      let env_tvs      = ic_tyvars (hsc_IC hsc_env)
  91          my_tvs       = termTyVars t
  92          tvs          = env_tvs `minusVarSet` my_tvs
  93          tyvarOccName = nameOccName . tyVarName
  94          tidyEnv      = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
  95                         , env_tvs `intersectVarSet` my_tvs)
  96      return$ mapTermType (snd . tidyOpenType tidyEnv) t
  97
  98 -- | Give names, and bind in the interactive environment, to all the suspensions
  99 --   included (inductively) in a term
 100 bindSuspensions :: Session -> Term -> IO Term
 101 bindSuspensions cms@(Session ref) t = do
 102       hsc_env <- readIORef ref
 103       inScope <- GHC.getBindings cms
 104       let ictxt        = hsc_IC hsc_env
 105           prefix       = "_t"
 106           alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
 107           availNames   = map ((prefix++) . show) [1..] \\ alreadyUsedNames
 108       availNames_var  <- newIORef availNames
 109       (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
 110       let (names, tys, hvals) = unzip3 stuff
 111       let tys' = map (fst.skolemiseTy) tys
 112       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
 113                 | (name,ty) <- zip names tys']
 114           new_tyvars   = tyVarsOfTypes tys'
 115           new_ic       = extendInteractiveContext ictxt ids new_tyvars
 116       extendLinkEnv (zip names hvals)
 117       writeIORef ref (hsc_env {hsc_IC = new_ic })
 118       return t'
 119      where
 120
 121 --    Processing suspensions. Give names and recopilate info
 122         nameSuspensionsAndGetInfos :: IORef [String] ->
 123                                        TermFold (IO (Term, [(Name,Type,HValue)]))
 124         nameSuspensionsAndGetInfos freeNames = TermFold
 125                       {
 126                         fSuspension = doSuspension freeNames
 127                       , fTerm = \ty dc v tt -> do
 128                                     tt' <- sequence tt
 129                                     let (terms,names) = unzip tt'
 130                                     return (Term ty dc v terms, concat names)
 131                       , fPrim    = \ty n ->return (Prim ty n,[])
 132                       }
 133         doSuspension freeNames ct mb_ty hval Nothing = do
 134           name <- atomicModifyIORef freeNames (\x->(tail x, head x))
 135           n <- newGrimName cms name
 136           let ty' = fromMaybe (error "unexpected") mb_ty
 137           return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])
 138
 139
 140 --  A custom Term printer to enable the use of Show instances
 141 printTerm cms@(Session ref) = cPprTerm cPpr
 142  where
 143   cPpr = \p-> cPprShowable : cPprTermBase p
 144   cPprShowable prec t@Term{ty=ty, dc=dc, val=val} = do
 145     let hasType = isEmptyVarSet (tyVarsOfType ty)  -- redundant
 146         isEvaled = isFullyEvaluatedTerm t
 147     if not isEvaled -- || not hasType
 148      then return Nothing
 149      else do
 150         hsc_env <- readIORef ref
 151         dflags  <- GHC.getSessionDynFlags cms
 152         do
 153            (new_env, bname) <- bindToFreshName hsc_env ty "showme"
 154            writeIORef ref (new_env)
 155            let noop_log _ _ _ _ = return ()
 156                expr = "show " ++ showSDoc (ppr bname)
 157            GHC.setSessionDynFlags cms dflags{log_action=noop_log}
 158            mb_txt <- withExtendedLinkEnv [(bname, val)]
 159                                          (GHC.compileExpr cms expr)
 160            let myprec = 10 -- application precedence. TODO Infix constructors
 161            case mb_txt of
 162              Just txt_ | txt <- unsafeCoerce# txt_, not (null txt)
 163                        -> return $ Just$ cparen (prec >= myprec &&
 164                                                       needsParens txt)
 165                                                 (text txt)
 166              _  -> return Nothing
 167          `finally` do
 168            writeIORef ref hsc_env
 169            GHC.setSessionDynFlags cms dflags
 170   needsParens ('"':txt) = False -- some simple heuristics to see whether parens
 171                                 -- are redundant in an arbitrary Show output
 172   needsParens ('(':txt) = False
 173   needsParens txt = ' ' `elem` txt
 174
 175
 176   bindToFreshName hsc_env ty userName = do
 177     name <- newGrimName cms userName
 178     let ictxt    = hsc_IC hsc_env
 179         tmp_ids  = ic_tmp_ids ictxt
 180         id       = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
 181         new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
 182     return (hsc_env {hsc_IC = new_ic }, name)
 183
 184 --    Create new uniques and give them sequentially numbered names
 185 --    newGrimName :: Session -> String -> IO Name
 186 newGrimName cms userName  = do
 187     us <- mkSplitUniqSupply 'b'
 188     let unique  = uniqFromSupply us
 189         occname = mkOccName varName userName
 190         name    = mkInternalName unique occname noSrcSpan
 191     return name