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