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 PrelNames
  19 import HscTypes
  20 import IdInfo
  21 --import Id
  22 import Var hiding ( varName )
  23 import VarSet
  24 import VarEnv
  25 import Name
  26 import NameEnv
  27 import RdrName
  28 import UniqSupply
  29 import Type
  30 import TcType
  31 import TyCon
  32 import TcGadt
  33 import GHC
  34 import GhciMonad
  35
  36 import Outputable
  37 import Pretty                    ( Mode(..), showDocWith )
  38 import FastString
  39 import SrcLoc
  40
  41 import Control.Exception
  42 import Control.Monad
  43 import Data.List
  44 import Data.Maybe
  45 import Data.IORef
  46
  47 import System.IO
  48 import GHC.Exts
  49
  50 #include "HsVersions.h"
  51
  52 -------------------------------------
  53 -- | The :print & friends commands
  54 -------------------------------------
  55 pprintClosureCommand :: Bool -> Bool -> String -> GHCi ()
  56 pprintClosureCommand bindThings force str = do
  57   cms <- getSession
  58   tythings <- (catMaybes . concat) `liftM`
  59                  mapM (\w -> io(GHC.parseName cms w >>=
  60                                 mapM (GHC.lookupName cms)))
  61                       (words str)
  62   substs <- catMaybes `liftM` mapM (io . go cms)
  63                                    [id | AnId id <- tythings]
  64   mapM (io . applySubstToEnv cms . skolemSubst) substs
  65   return ()
  66  where
  67
  68    -- Do the obtainTerm--bindSuspensions-refineIdType dance
  69    -- Warning! This function got a good deal of side-effects
  70    go :: Session -> Id -> IO (Maybe TvSubst)
  71    go cms id = do
  72      mb_term <- obtainTerm cms force id
  73      maybe (return Nothing) `flip` mb_term $ \term -> do
  74        term'     <- if not bindThings then return term
  75                      else bindSuspensions cms term
  76        showterm  <- printTerm cms term'
  77        unqual    <- GHC.getPrintUnqual cms
  78        let showSDocForUserOneLine unqual doc =
  79                showDocWith LeftMode (doc (mkErrStyle unqual))
  80        (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
  81      -- Before leaving, we compare the type obtained to see if it's more specific
  82      --  Then, we extract a substitution,
  83      --  mapping the old tyvars to the reconstructed types.
  84        let Just reconstructed_type = termType term
  85            mb_subst = tcUnifyTys (const BindMe) [idType id] [reconstructed_type]
  86        ASSERT (isJust mb_subst) return mb_subst
  87
  88    applySubstToEnv :: Session -> TvSubst -> IO ()
  89    applySubstToEnv cms subst | isEmptyTvSubst subst = return ()
  90    applySubstToEnv cms@(Session ref) subst = do
  91       hsc_env <- readIORef ref
  92       inScope <- GHC.getBindings cms
  93       let ictxt    = hsc_IC hsc_env
  94           type_env = ic_type_env ictxt
  95           ids      = typeEnvIds type_env
  96           ids'     = map (\id -> id `setIdType` substTy subst (idType id)) ids
  97           type_env'= extendTypeEnvWithIds type_env ids'
  98           ictxt'   = ictxt { ic_type_env = type_env' }
  99       writeIORef ref (hsc_env {hsc_IC = ictxt'})
 100
 101 -- | Give names, and bind in the interactive environment, to all the suspensions
 102 --   included (inductively) in a term
 103 bindSuspensions :: Session -> Term -> IO Term
 104 bindSuspensions cms@(Session ref) t = do
 105       hsc_env <- readIORef ref
 106       inScope <- GHC.getBindings cms
 107       let ictxt        = hsc_IC hsc_env
 108           rn_env       = ic_rn_local_env ictxt
 109           type_env     = ic_type_env ictxt
 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 ids = [ mkGlobalId VanillaGlobal name (mk_skol_ty ty) vanillaIdInfo
 117                   | (name,ty) <- zip names tys]
 118           new_type_env = extendTypeEnvWithIds type_env ids
 119           new_rn_env   = extendLocalRdrEnv rn_env names
 120           new_ic       = ictxt { ic_rn_local_env = new_rn_env,
 121                                  ic_type_env     = new_type_env }
 122       extendLinkEnv (zip names hvals)
 123       writeIORef ref (hsc_env {hsc_IC = new_ic })
 124       return t'
 125      where
 126
 127 --    Processing suspensions. Give names and recopilate info
 128         nameSuspensionsAndGetInfos :: IORef [String] -> 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 printTerm 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 = 9 -- TODO Infix constructors
 166            case mb_txt of
 167              Just txt -> return . Just . text . unsafeCoerce#
 168                            $ txt
 169              Nothing  -> return Nothing
 170          `finally` do
 171            writeIORef ref hsc_env
 172            GHC.setSessionDynFlags cms dflags
 173
 174   bindToFreshName hsc_env ty userName = do
 175     name <- newGrimName cms userName
 176     let ictxt    = hsc_IC hsc_env
 177         rn_env   = ic_rn_local_env ictxt
 178         type_env = ic_type_env ictxt
 179         id       = mkGlobalId VanillaGlobal name ty vanillaIdInfo
 180         new_type_env = extendTypeEnv type_env (AnId id)
 181         new_rn_env   = extendLocalRdrEnv rn_env [name]
 182         new_ic       = ictxt { ic_rn_local_env = new_rn_env,
 183                                ic_type_env     = new_type_env }
 184     return (hsc_env {hsc_IC = new_ic }, name)
 185
 186 --    Create new uniques and give them sequentially numbered names
 187 --    newGrimName :: Session -> String -> IO Name
 188 newGrimName cms userName  = do
 189     us <- mkSplitUniqSupply 'b'
 190     let unique  = uniqFromSupply us
 191         occname = mkOccName varName userName
 192         name    = mkInternalName unique occname noSrcLoc
 193     return name
 194
 195 skolemSubst subst = subst `setTvSubstEnv`
 196                       mapVarEnv mk_skol_ty (getTvSubstEnv subst)
 197 mk_skol_ty ty | tyvars  <- varSetElems (tyVarsOfType ty)
 198               , tyvars' <- map (mkTyVarTy . mk_skol_tv) tyvars
 199               = substTyWith tyvars tyvars' ty
 200 mk_skol_tv tv = mkTcTyVar (tyVarName tv) (tyVarKind tv)
 201                       (SkolemTv UnkSkol)