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 TyCon
  31 import TcGadt
  32 import GHC
  33 import GhciMonad
  34
  35 import Outputable
  36 import Pretty                    ( Mode(..), showDocWith )
  37 import FastString
  38 import SrcLoc
  39
  40 import Control.Exception
  41 import Control.Monad
  42 import Data.List
  43 import Data.Maybe
  44 import Data.IORef
  45
  46 import System.IO
  47 import GHC.Exts
  48
  49 #include "HsVersions.h"
  50
  51 -------------------------------------
  52 -- | The :print & friends commands
  53 -------------------------------------
  54 pprintClosureCommand :: Bool -> Bool -> String -> GHCi ()
  55 pprintClosureCommand bindThings force str = do
  56   cms <- getSession
  57   tythings <- (catMaybes . concat) `liftM`
  58                  mapM (\w -> io(GHC.parseName cms w >>=
  59                                 mapM (GHC.lookupName cms)))
  60                       (words str)
  61   substs <- catMaybes `liftM` mapM (io . go cms)
  62                                    [id | AnId id <- tythings]
  63   mapM (io . applySubstToEnv cms) substs
  64   return ()
  65  where
  66
  67    -- Do the obtainTerm--bindSuspensions-refineIdType dance
  68    -- Warning! This function got a good deal of side-effects
  69    go :: Session -> Id -> IO (Maybe TvSubst)
  70    go cms id = do
  71      mb_term <- obtainTerm cms force id
  72      maybe (return Nothing) `flip` mb_term $ \term -> do
  73        term'     <- if not bindThings then return term
  74                      else bindSuspensions cms term
  75        showterm  <- printTerm cms term'
  76        unqual    <- GHC.getPrintUnqual cms
  77        let showSDocForUserOneLine unqual doc =
  78                showDocWith LeftMode (doc (mkErrStyle unqual))
  79        (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
  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            mb_subst = tcUnifyTys (const BindMe) [idType id] [reconstructed_type]
  85        ASSERT (isJust mb_subst) return mb_subst
  86
  87    applySubstToEnv :: Session -> TvSubst -> IO ()
  88    applySubstToEnv cms subst | isEmptyTvSubst subst = return ()
  89    applySubstToEnv cms@(Session ref) subst = do
  90       hsc_env <- readIORef ref
  91       inScope <- GHC.getBindings cms
  92       let ictxt    = hsc_IC hsc_env
  93           type_env = ic_type_env ictxt
  94           ids      = typeEnvIds type_env
  95           ids'     = map (\id -> setIdType id (substTy subst (idType id))) ids
  96           type_env'= extendTypeEnvWithIds type_env ids'
  97           ictxt'   = ictxt { ic_type_env = type_env' }
  98       writeIORef ref (hsc_env {hsc_IC = ictxt'})
  99
 100 -- | Give names, and bind in the interactive environment, to all the suspensions
 101 --   included (inductively) in a term
 102 bindSuspensions :: Session -> Term -> IO Term
 103 bindSuspensions cms@(Session ref) t = do
 104       hsc_env <- readIORef ref
 105       inScope <- GHC.getBindings cms
 106       let ictxt        = hsc_IC hsc_env
 107           rn_env       = ic_rn_local_env ictxt
 108           type_env     = ic_type_env ictxt
 109           prefix       = "_t"
 110           alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
 111           availNames   = map ((prefix++) . show) [1..] \\ alreadyUsedNames
 112       availNames_var  <- newIORef availNames
 113       (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
 114       let (names, tys, hvals) = unzip3 stuff
 115       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
 116                   | (name,ty) <- zip names tys]
 117           new_type_env = extendTypeEnvWithIds type_env ids
 118           new_rn_env   = extendLocalRdrEnv rn_env names
 119           new_ic       = ictxt { ic_rn_local_env = new_rn_env,
 120                                  ic_type_env     = new_type_env }
 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] -> TermFold (IO (Term, [(Name,Type,HValue)]))
 128         nameSuspensionsAndGetInfos freeNames = TermFold
 129                       {
 130                         fSuspension = doSuspension freeNames
 131                       , fTerm = \ty dc v tt -> do
 132                                     tt' <- sequence tt
 133                                     let (terms,names) = unzip tt'
 134                                     return (Term ty dc v terms, concat names)
 135                       , fPrim    = \ty n ->return (Prim ty n,[])
 136                       }
 137         doSuspension freeNames ct mb_ty hval Nothing = do
 138           name <- atomicModifyIORef freeNames (\x->(tail x, head x))
 139           n <- newGrimName cms 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 printTerm cms@(Session ref) = cPprTerm cPpr
 146  where
 147   cPpr = \p-> cPprShowable : cPprTermBase p
 148   cPprShowable prec t@Term{ty=ty, dc=dc, val=val} = do
 149     let hasType = isEmptyVarSet (tyVarsOfType ty)  -- redundant
 150         isEvaled = isFullyEvaluatedTerm t
 151     if not isEvaled -- || not hasType
 152      then return Nothing
 153      else do
 154         hsc_env <- readIORef ref
 155         dflags  <- GHC.getSessionDynFlags cms
 156         do
 157            (new_env, bname) <- bindToFreshName hsc_env ty "showme"
 158            writeIORef ref (new_env)
 159            let noop_log _ _ _ _ = return ()
 160                expr = "show " ++ showSDoc (ppr bname)
 161            GHC.setSessionDynFlags cms dflags{log_action=noop_log}
 162            mb_txt <- withExtendedLinkEnv [(bname, val)]
 163                                          (GHC.compileExpr cms expr)
 164            let myprec = 9 -- TODO Infix constructors
 165            case mb_txt of
 166              Just txt -> return . Just . text . unsafeCoerce#
 167                            $ txt
 168              Nothing  -> return Nothing
 169          `finally` do
 170            writeIORef ref hsc_env
 171            GHC.setSessionDynFlags cms dflags
 172
 173   bindToFreshName hsc_env ty userName = do
 174     name <- newGrimName cms userName
 175     let ictxt    = hsc_IC hsc_env
 176         rn_env   = ic_rn_local_env ictxt
 177         type_env = ic_type_env ictxt
 178         id       = mkGlobalId VanillaGlobal name ty vanillaIdInfo
 179         new_type_env = extendTypeEnv type_env (AnId id)
 180         new_rn_env   = extendLocalRdrEnv rn_env [name]
 181         new_ic       = ictxt { ic_rn_local_env = new_rn_env,
 182                                ic_type_env     = new_type_env }
 183     return (hsc_env {hsc_IC = new_ic }, name)
 184
 185 --    Create new uniques and give them sequentially numbered names
 186 --    newGrimName :: Session -> String -> IO Name
 187 newGrimName cms userName  = do
 188     us <- mkSplitUniqSupply 'b'
 189     let unique  = uniqFromSupply us
 190         occname = mkOccName varName userName
 191         name    = mkInternalName unique occname noSrcLoc
 192     return name