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 qualified DebuggerTys
  16 import Linker
  17 import RtClosureInspect
  18
  19 import PrelNames
  20 import HscTypes
  21 import IdInfo
  22 --import Id
  23 import Var hiding ( varName )
  24 import VarSet
  25 import VarEnv
  26 import Name
  27 import NameEnv
  28 import RdrName
  29 import UniqSupply
  30 import Type
  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   newvarsNames <- io$ do
  59            uniques <- liftM uniqsFromSupply (mkSplitUniqSupply 'q')
  60            return$ map (\u-> (mkSysTvName u (mkFastString "a"))) uniques
  61   mb_ids  <- io$ mapM (cleanUp cms newvarsNames) (words str)
  62   mb_new_ids <- mapM (io . go cms) (catMaybes mb_ids)
  63   io$ updateIds cms (catMaybes mb_new_ids)
  64  where
  65    -- Find the Id
  66    cleanUp :: Session -> [Name] -> String -> IO (Maybe Id)
  67    cleanUp cms newNames str = do
  68      tythings <- GHC.parseName cms str >>= mapM (GHC.lookupName cms)
  69      return$ listToMaybe [ i | Just (AnId i) <- tythings]
  70
  71    -- Do the obtainTerm--bindSuspensions-refineIdType dance
  72    -- Warning! This function got a good deal of side-effects
  73    go :: Session -> Id -> IO (Maybe Id)
  74    go cms id = do
  75      mb_term <- obtainTerm cms force id
  76      maybe (return Nothing) `flip` mb_term $ \term -> do
  77        term'     <- if not bindThings then return term
  78                      else bindSuspensions cms term
  79        showterm  <- printTerm cms term'
  80        unqual    <- GHC.getPrintUnqual cms
  81        let showSDocForUserOneLine unqual doc =
  82                showDocWith LeftMode (doc (mkErrStyle unqual))
  83        (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
  84      -- Before leaving, we compare the type obtained to see if it's more specific
  85        let Just reconstructedType = termType term
  86            new_type = mostSpecificType (idType id) reconstructedType
  87        return . Just $ setIdType id new_type
  88
  89    updateIds :: Session -> [Id] -> IO ()
  90    updateIds (Session ref) new_ids = do
  91      hsc_env <- readIORef ref
  92      let ictxt = hsc_IC hsc_env
  93          type_env = ic_type_env ictxt
  94          filtered_type_env = delListFromNameEnv type_env (map idName new_ids)
  95          new_type_env =  extendTypeEnvWithIds filtered_type_env new_ids
  96          new_ic = ictxt {ic_type_env = new_type_env }
  97      writeIORef ref (hsc_env {hsc_IC = new_ic })
  98
  99 isMoreSpecificThan :: Type -> Type -> Bool
 100 ty `isMoreSpecificThan` ty1
 101       | Just subst    <- tcUnifyTys bindOnlyTy1 [repType' ty] [repType' ty1]
 102       , substFiltered <- filter (not.isTyVarTy) . varEnvElts . getTvSubstEnv $ subst
 103       , not . null $ substFiltered
 104       , all (flip notElemTvSubst subst) ty_vars
 105       = True
 106       | otherwise = False
 107       where bindOnlyTy1 tyv | tyv `elem` ty_vars = AvoidMe
 108                             | otherwise = BindMe
 109             ty_vars = varSetElems$ tyVarsOfType ty
 110
 111 mostSpecificType ty1 ty2 | ty1 `isMoreSpecificThan` ty2 = ty1
 112                          | otherwise = ty2
 113
 114 -- | Give names, and bind in the interactive environment, to all the suspensions
 115 --   included (inductively) in a term
 116 bindSuspensions :: Session -> Term -> IO Term
 117 bindSuspensions cms@(Session ref) t = do
 118       hsc_env <- readIORef ref
 119       inScope <- GHC.getBindings cms
 120       let ictxt        = hsc_IC hsc_env
 121           rn_env       = ic_rn_local_env ictxt
 122           type_env     = ic_type_env ictxt
 123           prefix       = "_t"
 124           alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
 125           availNames   = map ((prefix++) . show) [1..] \\ alreadyUsedNames
 126       availNames_var  <- newIORef availNames
 127       (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
 128       let (names, tys, hvals) = unzip3 stuff
 129       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
 130                   | (name,ty) <- zip names tys]
 131           new_type_env = extendTypeEnvWithIds type_env ids
 132           new_rn_env   = extendLocalRdrEnv rn_env names
 133           new_ic       = ictxt { ic_rn_local_env = new_rn_env,
 134                                  ic_type_env     = new_type_env }
 135       extendLinkEnv (zip names hvals)
 136       writeIORef ref (hsc_env {hsc_IC = new_ic })
 137       return t'
 138      where
 139
 140 --    Processing suspensions. Give names and recopilate info
 141         nameSuspensionsAndGetInfos :: IORef [String] -> TermFold (IO (Term, [(Name,Type,HValue)]))
 142         nameSuspensionsAndGetInfos freeNames = TermFold
 143                       {
 144                         fSuspension = doSuspension freeNames
 145                       , fTerm = \ty dc v tt -> do
 146                                     tt' <- sequence tt
 147                                     let (terms,names) = unzip tt'
 148                                     return (Term ty dc v terms, concat names)
 149                       , fPrim    = \ty n ->return (Prim ty n,[])
 150                       }
 151         doSuspension freeNames ct mb_ty hval Nothing = do
 152           name <- atomicModifyIORef freeNames (\x->(tail x, head x))
 153           n <- newGrimName cms name
 154           let ty' = fromMaybe (error "unexpected") mb_ty
 155           return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])
 156
 157
 158 --  A custom Term printer to enable the use of Show instances
 159 printTerm cms@(Session ref) = cPprTerm cPpr
 160  where
 161   cPpr = \p-> cPprShowable : cPprTermBase p
 162   cPprShowable prec t@Term{ty=ty, dc=dc, val=val} = do
 163     let hasType = isEmptyVarSet (tyVarsOfType ty)  -- redundant
 164         isEvaled = isFullyEvaluatedTerm t
 165     if not isEvaled -- || not hasType
 166      then return Nothing
 167      else do
 168         hsc_env <- readIORef ref
 169         dflags  <- GHC.getSessionDynFlags cms
 170         do
 171            (new_env, bname) <- bindToFreshName hsc_env ty "showme"
 172            writeIORef ref (new_env)
 173            let noop_log _ _ _ _ = return ()
 174                expr = "show " ++ showSDoc (ppr bname)
 175            GHC.setSessionDynFlags cms dflags{log_action=noop_log}
 176            mb_txt <- withExtendedLinkEnv [(bname, val)]
 177                                          (GHC.compileExpr cms expr)
 178            let myprec = 9 -- TODO Infix constructors
 179            case mb_txt of
 180              Just txt -> return . Just . text . unsafeCoerce#
 181                            $ txt
 182              Nothing  -> return Nothing
 183          `finally` do
 184            writeIORef ref hsc_env
 185            GHC.setSessionDynFlags cms dflags
 186
 187   bindToFreshName hsc_env ty userName = do
 188     name <- newGrimName cms userName
 189     let ictxt    = hsc_IC hsc_env
 190         rn_env   = ic_rn_local_env ictxt
 191         type_env = ic_type_env ictxt
 192         id       = mkGlobalId VanillaGlobal name ty vanillaIdInfo
 193         new_type_env = extendTypeEnv type_env (AnId id)
 194         new_rn_env   = extendLocalRdrEnv rn_env [name]
 195         new_ic       = ictxt { ic_rn_local_env = new_rn_env,
 196                                ic_type_env     = new_type_env }
 197     return (hsc_env {hsc_IC = new_ic }, name)
 198
 199 --    Create new uniques and give them sequentially numbered names
 200 --    newGrimName :: Session -> String -> IO Name
 201 newGrimName cms userName  = do
 202     us <- mkSplitUniqSupply 'b'
 203     let unique  = uniqFromSupply us
 204         occname = mkOccName varName userName
 205         name    = mkInternalName unique occname noSrcLoc
 206     return name