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 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   let ids = [id | AnId id <- tythings]
  58
  59   -- Obtain the terms and the recovered type information
  60   (terms, substs) <- unzip `liftM` mapM (go session) ids
  61
  62   -- Apply the substitutions obtained after recovering the types
  63   modifySession session $ \hsc_env ->
  64          hsc_env{hsc_IC = foldr (flip substInteractiveContext)
  65                                 (hsc_IC hsc_env)
  66                                 (map skolemiseSubst substs)}
  67   -- Finally, print the Terms
  68   unqual  <- GHC.getPrintUnqual session
  69   let showSDocForUserOneLine unqual doc =
  70                showDocWith LeftMode (doc (mkErrStyle unqual))
  71   docterms <- mapM (showTerm session) terms
  72   (putStrLn . showSDocForUserOneLine unqual . vcat)
  73         (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
  74                  ids
  75                  docterms)
  76  where
  77
  78    -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
  79    go :: Session -> Id -> IO (Term, TvSubst)
  80    go cms id = do
  81        term_    <- GHC.obtainTerm cms force id
  82        term     <- tidyTermTyVars cms term_
  83        term'    <- if not bindThings then return term
  84                      else bindSuspensions cms term
  85      -- Before leaving, we compare the type obtained to see if it's more specific
  86      --  Then, we extract a substitution,
  87      --  mapping the old tyvars to the reconstructed types.
  88        let Just reconstructed_type = termType term
  89            Just subst = computeRTTIsubst (idType id) (reconstructed_type)
  90        return (term',subst)
  91
  92    tidyTermTyVars :: Session -> Term -> IO Term
  93    tidyTermTyVars (Session ref) t = do
  94      hsc_env <- readIORef ref
  95      let env_tvs      = ic_tyvars (hsc_IC hsc_env)
  96          my_tvs       = termTyVars t
  97          tvs          = env_tvs `minusVarSet` my_tvs
  98          tyvarOccName = nameOccName . tyVarName
  99          tidyEnv      = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
 100                         , env_tvs `intersectVarSet` my_tvs)
 101      return$ mapTermType (snd . tidyOpenType tidyEnv) t
 102
 103 -- | Give names, and bind in the interactive environment, to all the suspensions
 104 --   included (inductively) in a term
 105 bindSuspensions :: Session -> Term -> IO Term
 106 bindSuspensions cms@(Session ref) t = do
 107       hsc_env <- readIORef ref
 108       inScope <- GHC.getBindings cms
 109       let ictxt        = hsc_IC hsc_env
 110           prefix       = "_t"
 111           alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
 112           availNames   = map ((prefix++) . show) [1..] \\ alreadyUsedNames
 113       availNames_var  <- newIORef availNames
 114       (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
 115       let (names, tys, hvals) = unzip3 stuff
 116       let tys' = map (fst.skolemiseTy) tys
 117       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
 118                 | (name,ty) <- zip names tys']
 119           new_tyvars   = tyVarsOfTypes tys'
 120           new_ic       = extendInteractiveContext ictxt ids new_tyvars
 121       extendLinkEnv (zip names hvals)
 122       writeIORef ref (hsc_env {hsc_IC = new_ic })
 123       return t'
 124      where
 125
 126 --    Processing suspensions. Give names and recopilate info
 127         nameSuspensionsAndGetInfos :: IORef [String] ->
 128                                        TermFold (IO (Term, [(Name,Type,HValue)]))
 129         nameSuspensionsAndGetInfos freeNames = TermFold
 130                       {
 131                         fSuspension = doSuspension freeNames
 132                       , fTerm = \ty dc v tt -> do
 133                                     tt' <- sequence tt
 134                                     let (terms,names) = unzip tt'
 135                                     return (Term ty dc v terms, concat names)
 136                       , fPrim    = \ty n ->return (Prim ty n,[])
 137                       }
 138         doSuspension freeNames ct mb_ty hval Nothing = do
 139           name <- atomicModifyIORef freeNames (\x->(tail x, head x))
 140           n <- newGrimName cms name
 141           let ty' = fromMaybe (error "unexpected") mb_ty
 142           return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])
 143
 144
 145 --  A custom Term printer to enable the use of Show instances
 146 showTerm cms@(Session ref) = cPprTerm cPpr
 147  where
 148   cPpr = \p-> cPprShowable : cPprTermBase p
 149   cPprShowable prec t@Term{ty=ty, dc=dc, val=val} = do
 150     let hasType = isEmptyVarSet (tyVarsOfType ty)  -- redundant
 151         isEvaled = isFullyEvaluatedTerm t
 152     if not isEvaled -- || not hasType
 153      then return Nothing
 154      else do
 155         hsc_env <- readIORef ref
 156         dflags  <- GHC.getSessionDynFlags cms
 157         do
 158            (new_env, bname) <- bindToFreshName hsc_env ty "showme"
 159            writeIORef ref (new_env)
 160            let noop_log _ _ _ _ = return ()
 161                expr = "show " ++ showSDoc (ppr bname)
 162            GHC.setSessionDynFlags cms dflags{log_action=noop_log}
 163            mb_txt <- withExtendedLinkEnv [(bname, val)]
 164                                          (GHC.compileExpr cms expr)
 165            let myprec = 10 -- application precedence. TODO Infix constructors
 166            case mb_txt of
 167              Just txt_ | txt <- unsafeCoerce# txt_, not (null txt)
 168                        -> return $ Just$ cparen (prec >= myprec &&
 169                                                       needsParens txt)
 170                                                 (text txt)
 171              _  -> return Nothing
 172          `finally` do
 173            writeIORef ref hsc_env
 174            GHC.setSessionDynFlags cms dflags
 175   needsParens ('"':txt) = False -- some simple heuristics to see whether parens
 176                                 -- are redundant in an arbitrary Show output
 177   needsParens ('(':txt) = False
 178   needsParens txt = ' ' `elem` txt
 179
 180
 181   bindToFreshName hsc_env ty userName = do
 182     name <- newGrimName cms userName
 183     let ictxt    = hsc_IC hsc_env
 184         tmp_ids  = ic_tmp_ids ictxt
 185         id       = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
 186         new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
 187     return (hsc_env {hsc_IC = new_ic }, name)
 188
 189 --    Create new uniques and give them sequentially numbered names
 190 --    newGrimName :: Session -> String -> IO Name
 191 newGrimName cms userName  = do
 192     us <- mkSplitUniqSupply 'b'
 193     let unique  = uniqFromSupply us
 194         occname = mkOccName varName userName
 195         name    = mkInternalName unique occname noSrcSpan
 196     return name