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           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 tys' = map mk_skol_ty tys
 116       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
 117                 | (name,ty) <- zip names tys']
 118           new_tyvars   = tyVarsOfTypes tys'
 119           new_type_env = extendTypeEnvWithIds type_env ids
 120           old_tyvars   = ic_tyvars ictxt
 121           new_ic       = ictxt { ic_type_env = new_type_env,
 122                                  ic_tyvars   = old_tyvars `unionVarSet` new_tyvars }
 123       extendLinkEnv (zip names hvals)
 124       writeIORef ref (hsc_env {hsc_IC = new_ic })
 125       return t'
 126      where
 127
 128 --    Processing suspensions. Give names and recopilate info
 129         nameSuspensionsAndGetInfos :: IORef [String] -> TermFold (IO (Term, [(Name,Type,HValue)]))
 130         nameSuspensionsAndGetInfos freeNames = TermFold
 131                       {
 132                         fSuspension = doSuspension freeNames
 133                       , fTerm = \ty dc v tt -> do
 134                                     tt' <- sequence tt
 135                                     let (terms,names) = unzip tt'
 136                                     return (Term ty dc v terms, concat names)
 137                       , fPrim    = \ty n ->return (Prim ty n,[])
 138                       }
 139         doSuspension freeNames ct mb_ty hval Nothing = do
 140           name <- atomicModifyIORef freeNames (\x->(tail x, head x))
 141           n <- newGrimName cms name
 142           let ty' = fromMaybe (error "unexpected") mb_ty
 143           return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])
 144
 145
 146 --  A custom Term printer to enable the use of Show instances
 147 printTerm cms@(Session ref) = cPprTerm cPpr
 148  where
 149   cPpr = \p-> cPprShowable : cPprTermBase p
 150   cPprShowable prec t@Term{ty=ty, dc=dc, val=val} = do
 151     let hasType = isEmptyVarSet (tyVarsOfType ty)  -- redundant
 152         isEvaled = isFullyEvaluatedTerm t
 153     if not isEvaled -- || not hasType
 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 = 9 -- TODO Infix constructors
 167            case mb_txt of
 168              Just txt -> return . Just . text . unsafeCoerce#
 169                            $ txt
 170              Nothing  -> return Nothing
 171          `finally` do
 172            writeIORef ref hsc_env
 173            GHC.setSessionDynFlags cms dflags
 174
 175   bindToFreshName hsc_env ty userName = do
 176     name <- newGrimName cms userName
 177     let ictxt    = hsc_IC hsc_env
 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_ic       = ictxt { ic_type_env     = new_type_env }
 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 noSrcLoc
 191     return name
 192
 193 skolemSubst subst = subst `setTvSubstEnv`
 194                       mapVarEnv mk_skol_ty (getTvSubstEnv subst)
 195 mk_skol_ty ty | tyvars  <- varSetElems (tyVarsOfType ty)
 196               , tyvars' <- map (mkTyVarTy . mk_skol_tv) tyvars
 197               = substTyWith tyvars tyvars' ty
 198 mk_skol_tv tv = mkTcTyVar (tyVarName tv) (tyVarKind tv)
 199                       (SkolemTv UnkSkol)