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, showTerm) 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 Name
  25 import UniqSupply
  26 import TcType
  27 import GHC
  28 import DynFlags
  29 import InteractiveEval
  30 import Outputable
  31 import Pretty                    ( Mode(..), showDocWith )
  32 import SrcLoc
  33
  34 import Control.Exception
  35 import Control.Monad
  36 import Data.List
  37 import Data.Maybe
  38 import Data.IORef
  39
  40 import System.IO
  41 import GHC.Exts
  42
  43 -------------------------------------
  44 -- | The :print & friends commands
  45 -------------------------------------
  46 pprintClosureCommand :: Session -> Bool -> Bool -> String -> IO ()
  47 pprintClosureCommand session bindThings force str = do
  48   tythings <- (catMaybes . concat) `liftM`
  49                  mapM (\w -> GHC.parseName session w >>=
  50                                 mapM (GHC.lookupName session))
  51                       (words str)
  52   let ids = [id | AnId id <- tythings]
  53
  54   -- Obtain the terms and the recovered type information
  55   (terms, substs) <- unzip `liftM` mapM (go session) ids
  56
  57   -- Apply the substitutions obtained after recovering the types
  58   modifySession session $ \hsc_env ->
  59          hsc_env{hsc_IC = foldr (flip substInteractiveContext)
  60                                 (hsc_IC hsc_env)
  61                                 (map skolemiseSubst substs)}
  62   -- Finally, print the Terms
  63   unqual  <- GHC.getPrintUnqual session
  64   let showSDocForUserOneLine unqual doc =
  65                showDocWith LeftMode (doc (mkErrStyle unqual))
  66   docterms <- mapM (showTerm session) terms
  67   (putStrLn . showSDocForUserOneLine unqual . vcat)
  68         (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
  69                  ids
  70                  docterms)
  71  where
  72
  73    -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
  74    go :: Session -> Id -> IO (Term, TvSubst)
  75    go cms id = do
  76        term_    <- GHC.obtainTerm cms force id
  77        term     <- tidyTermTyVars cms term_
  78        term'    <- if not bindThings then return term
  79                      else bindSuspensions cms term
  80      -- Before leaving, we compare the type obtained to see if it's more specific
  81      --  Then, we extract a substitution,
  82      --  mapping the old tyvars to the reconstructed types.
  83        let Just reconstructed_type = termType term
  84            subst = computeRTTIsubst (idType id) (reconstructed_type)
  85        return (term',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::Int)..] \\ 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                       , fNewtypeWrap  =
 133                                 \ty dc t -> do
 134                                     (term, names) <- t
 135                                     return (NewtypeWrap ty dc term, names)
 136                       }
 137         doSuspension freeNames ct mb_ty hval _name = do
 138           name <- atomicModifyIORef freeNames (\x->(tail x, head x))
 139           n <- newGrimName name
 140           let ty' = fromMaybe (error "unexpected") mb_ty
 141           return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])
 142
 143
 144 --  A custom Term printer to enable the use of Show instances
 145 showTerm :: Session -> Term -> IO SDoc
 146 showTerm cms@(Session ref) term = do
 147     dflags       <- GHC.getSessionDynFlags cms
 148     if dopt Opt_PrintEvldWithShow dflags
 149        then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
 150        else cPprTerm cPprTermBase term
 151  where
 152   cPprShowable prec t@Term{ty=ty, val=val} =
 153     if not (isFullyEvaluatedTerm t)
 154      then return Nothing
 155      else do
 156         hsc_env <- readIORef ref
 157         dflags  <- GHC.getSessionDynFlags cms
 158         do
 159            (new_env, bname) <- bindToFreshName hsc_env ty "showme"
 160            writeIORef ref (new_env)
 161            let noop_log _ _ _ _ = return ()
 162                expr = "show " ++ showSDoc (ppr bname)
 163            GHC.setSessionDynFlags cms dflags{log_action=noop_log}
 164            mb_txt <- withExtendedLinkEnv [(bname, val)]
 165                                          (GHC.compileExpr cms expr)
 166            let myprec = 10 -- application precedence. TODO Infix constructors
 167            case mb_txt of
 168              Just txt_ | txt <- unsafeCoerce# txt_, not (null txt)
 169                        -> return $ Just$ cparen (prec >= myprec &&
 170                                                       needsParens txt)
 171                                                 (text txt)
 172              _  -> return Nothing
 173          `finally` do
 174            writeIORef ref hsc_env
 175            GHC.setSessionDynFlags cms dflags
 176   cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =
 177       cPprShowable prec t{ty=new_ty}
 178   cPprShowable _ _ = panic "cPprShowable - unreachable"
 179
 180   needsParens ('"':_) = False   -- some simple heuristics to see whether parens
 181                                 -- are redundant in an arbitrary Show output
 182   needsParens ('(':_) = False
 183   needsParens txt = ' ' `elem` txt
 184
 185
 186   bindToFreshName hsc_env ty userName = do
 187     name <- newGrimName userName
 188     let ictxt    = hsc_IC hsc_env
 189         tmp_ids  = ic_tmp_ids ictxt
 190         id       = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
 191         new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
 192     return (hsc_env {hsc_IC = new_ic }, name)
 193
 194 --    Create new uniques and give them sequentially numbered names
 195 newGrimName :: String -> IO Name
 196 newGrimName userName  = do
 197     us <- mkSplitUniqSupply 'b'
 198     let unique  = uniqFromSupply us
 199         occname = mkOccName varName userName
 200         name    = mkInternalName unique occname noSrcSpan
 201     return name