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 {-# OPTIONS -w #-}
  14 -- The above warning supression flag is a temporary kludge.
  15 -- While working on this module you are encouraged to remove it and fix
  16 -- any warnings in the module. See
  17 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  18 -- for details
  19
  20 module Debugger (pprintClosureCommand, showTerm) where
  21
  22 import Linker
  23 import RtClosureInspect
  24
  25 import HscTypes
  26 import IdInfo
  27 --import Id
  28 import Name
  29 import Var hiding ( varName )
  30 import VarSet
  31 import Name
  32 import UniqSupply
  33 import TcType
  34 import GHC
  35 import InteractiveEval
  36 import Outputable
  37 import Pretty                    ( Mode(..), showDocWith )
  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 -- | The :print & friends commands
  52 -------------------------------------
  53 pprintClosureCommand :: Session -> Bool -> Bool -> String -> IO ()
  54 pprintClosureCommand session bindThings force str = do
  55   tythings <- (catMaybes . concat) `liftM`
  56                  mapM (\w -> GHC.parseName session w >>=
  57                                 mapM (GHC.lookupName session))
  58                       (words str)
  59   let ids = [id | AnId id <- tythings]
  60
  61   -- Obtain the terms and the recovered type information
  62   (terms, substs) <- unzip `liftM` mapM (go session) ids
  63
  64   -- Apply the substitutions obtained after recovering the types
  65   modifySession session $ \hsc_env ->
  66          hsc_env{hsc_IC = foldr (flip substInteractiveContext)
  67                                 (hsc_IC hsc_env)
  68                                 (map skolemiseSubst substs)}
  69   -- Finally, print the Terms
  70   unqual  <- GHC.getPrintUnqual session
  71   let showSDocForUserOneLine unqual doc =
  72                showDocWith LeftMode (doc (mkErrStyle unqual))
  73   docterms <- mapM (showTerm session) terms
  74   (putStrLn . showSDocForUserOneLine unqual . vcat)
  75         (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)
  76                  ids
  77                  docterms)
  78  where
  79
  80    -- Do the obtainTerm--bindSuspensions-computeSubstitution dance
  81    go :: Session -> Id -> IO (Term, TvSubst)
  82    go cms id = do
  83        term_    <- GHC.obtainTerm cms force id
  84        term     <- tidyTermTyVars cms term_
  85        term'    <- if not bindThings then return term
  86                      else bindSuspensions cms term
  87      -- Before leaving, we compare the type obtained to see if it's more specific
  88      --  Then, we extract a substitution,
  89      --  mapping the old tyvars to the reconstructed types.
  90        let Just reconstructed_type = termType term
  91            Just subst = computeRTTIsubst (idType id) (reconstructed_type)
  92        return (term',subst)
  93
  94    tidyTermTyVars :: Session -> Term -> IO Term
  95    tidyTermTyVars (Session ref) t = do
  96      hsc_env <- readIORef ref
  97      let env_tvs      = ic_tyvars (hsc_IC hsc_env)
  98          my_tvs       = termTyVars t
  99          tvs          = env_tvs `minusVarSet` my_tvs
 100          tyvarOccName = nameOccName . tyVarName
 101          tidyEnv      = (initTidyOccEnv (map tyvarOccName (varSetElems tvs))
 102                         , env_tvs `intersectVarSet` my_tvs)
 103      return$ mapTermType (snd . tidyOpenType tidyEnv) t
 104
 105 -- | Give names, and bind in the interactive environment, to all the suspensions
 106 --   included (inductively) in a term
 107 bindSuspensions :: Session -> Term -> IO Term
 108 bindSuspensions cms@(Session ref) t = do
 109       hsc_env <- readIORef ref
 110       inScope <- GHC.getBindings cms
 111       let ictxt        = hsc_IC hsc_env
 112           prefix       = "_t"
 113           alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
 114           availNames   = map ((prefix++) . show) [1..] \\ alreadyUsedNames
 115       availNames_var  <- newIORef availNames
 116       (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
 117       let (names, tys, hvals) = unzip3 stuff
 118       let tys' = map (fst.skolemiseTy) tys
 119       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
 120                 | (name,ty) <- zip names tys']
 121           new_tyvars   = tyVarsOfTypes tys'
 122           new_ic       = extendInteractiveContext ictxt ids 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] ->
 130                                        TermFold (IO (Term, [(Name,Type,HValue)]))
 131         nameSuspensionsAndGetInfos freeNames = TermFold
 132                       {
 133                         fSuspension = doSuspension freeNames
 134                       , fTerm = \ty dc v tt -> do
 135                                     tt' <- sequence tt
 136                                     let (terms,names) = unzip tt'
 137                                     return (Term ty dc v terms, concat names)
 138                       , fPrim    = \ty n ->return (Prim ty n,[])
 139                       }
 140         doSuspension freeNames ct mb_ty hval Nothing = do
 141           name <- atomicModifyIORef freeNames (\x->(tail x, head x))
 142           n <- newGrimName cms name
 143           let ty' = fromMaybe (error "unexpected") mb_ty
 144           return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])
 145
 146
 147 --  A custom Term printer to enable the use of Show instances
 148 showTerm cms@(Session ref) = cPprTerm cPpr
 149  where
 150   cPpr = \p-> cPprShowable : cPprTermBase p
 151   cPprShowable prec t@Term{ty=ty, dc=dc, val=val} =
 152     if not (isFullyEvaluatedTerm t)
 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 = 10 -- application precedence. TODO Infix constructors
 166            case mb_txt of
 167              Just txt_ | txt <- unsafeCoerce# txt_, not (null txt)
 168                        -> return $ Just$ cparen (prec >= myprec &&
 169                                                       needsParens txt)
 170                                                 (text txt)
 171              _  -> return Nothing
 172          `finally` do
 173            writeIORef ref hsc_env
 174            GHC.setSessionDynFlags cms dflags
 175   needsParens ('"':txt) = False -- some simple heuristics to see whether parens
 176                                 -- are redundant in an arbitrary Show output
 177   needsParens ('(':txt) = False
 178   needsParens txt = ' ' `elem` txt
 179
 180
 181   bindToFreshName hsc_env ty userName = do
 182     name <- newGrimName cms userName
 183     let ictxt    = hsc_IC hsc_env
 184         tmp_ids  = ic_tmp_ids ictxt
 185         id       = mkGlobalId VanillaGlobal name (sigmaType ty) vanillaIdInfo
 186         new_ic   = ictxt { ic_tmp_ids = id : tmp_ids }
 187     return (hsc_env {hsc_IC = new_ic }, name)
 188
 189 --    Create new uniques and give them sequentially numbered names
 190 --    newGrimName :: Session -> String -> IO Name
 191 newGrimName cms userName  = do
 192     us <- mkSplitUniqSupply 'b'
 193     let unique  = uniqFromSupply us
 194         occname = mkOccName varName userName
 195         name    = mkInternalName unique occname noSrcSpan
 196     return name