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, clean up 'Unknowns' in the idType
  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 (map (stripUnknowns newNames)
  70                               [ i | Just (AnId i) <- tythings])
  71
  72    -- Do the obtainTerm--bindSuspensions-refineIdType dance
  73    -- Warning! This function got a good deal of side-effects
  74    go :: Session -> Id -> IO (Maybe Id)
  75    go cms id = do
  76      mb_term <- obtainTerm cms force id
  77      maybe (return Nothing) `flip` mb_term $ \term -> do
  78        term'     <- if not bindThings then return term
  79                      else bindSuspensions cms term
  80        showterm  <- printTerm cms term'
  81        unqual    <- GHC.getPrintUnqual cms
  82        let showSDocForUserOneLine unqual doc =
  83                showDocWith LeftMode (doc (mkErrStyle unqual))
  84        (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
  85      -- Before leaving, we compare the type obtained to see if it's more specific
  86      -- Note how we need the Unknown-clear type returned by obtainTerm
  87        let Just reconstructedType = termType term
  88        new_type  <- instantiateTyVarsToUnknown cms
  89                     (mostSpecificType (idType id) reconstructedType)
  90        return . Just $ setIdType id new_type
  91
  92    updateIds :: Session -> [Id] -> IO ()
  93    updateIds (Session ref) new_ids = do
  94      hsc_env <- readIORef ref
  95      let ictxt = hsc_IC hsc_env
  96          type_env = ic_type_env ictxt
  97          filtered_type_env = delListFromNameEnv type_env (map idName new_ids)
  98          new_type_env =  extendTypeEnvWithIds filtered_type_env new_ids
  99          new_ic = ictxt {ic_type_env = new_type_env }
 100      writeIORef ref (hsc_env {hsc_IC = new_ic })
 101
 102 isMoreSpecificThan :: Type -> Type -> Bool
 103 ty `isMoreSpecificThan` ty1
 104       | Just subst    <- tcUnifyTys bindOnlyTy1 [repType' ty] [repType' ty1]
 105       , substFiltered <- filter (not.isTyVarTy) . varEnvElts . getTvSubstEnv $ subst
 106       , not . null $ substFiltered
 107       , all (flip notElemTvSubst subst) ty_vars
 108       = True
 109       | otherwise = False
 110       where bindOnlyTy1 tyv | tyv `elem` ty_vars = AvoidMe
 111                             | otherwise = BindMe
 112             ty_vars = varSetElems$ tyVarsOfType ty
 113
 114 mostSpecificType ty1 ty2 | ty1 `isMoreSpecificThan` ty2 = ty1
 115                          | otherwise = ty2
 116
 117 -- | Give names, and bind in the interactive environment, to all the suspensions
 118 --   included (inductively) in a term
 119 bindSuspensions :: Session -> Term -> IO Term
 120 bindSuspensions cms@(Session ref) t = do
 121       hsc_env <- readIORef ref
 122       inScope <- GHC.getBindings cms
 123       let ictxt        = hsc_IC hsc_env
 124           rn_env       = ic_rn_local_env ictxt
 125           type_env     = ic_type_env ictxt
 126           prefix       = "_t"
 127           alreadyUsedNames = map (occNameString . nameOccName . getName) inScope
 128           availNames   = map ((prefix++) . show) [1..] \\ alreadyUsedNames
 129       availNames_var  <- newIORef availNames
 130       (t', stuff)     <- foldTerm (nameSuspensionsAndGetInfos availNames_var) t
 131       let (names, tys, hvals) = unzip3 stuff
 132       concrete_tys    <- mapM (instantiateTyVarsToUnknown cms) tys
 133       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
 134                   | (name,ty) <- zip names concrete_tys]
 135           new_type_env = extendTypeEnvWithIds type_env ids
 136           new_rn_env   = extendLocalRdrEnv rn_env names
 137           new_ic       = ictxt { ic_rn_local_env = new_rn_env,
 138                                  ic_type_env     = new_type_env }
 139       extendLinkEnv (zip names hvals)
 140       writeIORef ref (hsc_env {hsc_IC = new_ic })
 141       return t'
 142      where
 143
 144 --    Processing suspensions. Give names and recopilate info
 145         nameSuspensionsAndGetInfos :: IORef [String] -> TermFold (IO (Term, [(Name,Type,HValue)]))
 146         nameSuspensionsAndGetInfos freeNames = TermFold
 147                       {
 148                         fSuspension = doSuspension freeNames
 149                       , fTerm = \ty dc v tt -> do
 150                                     tt' <- sequence tt
 151                                     let (terms,names) = unzip tt'
 152                                     return (Term ty dc v terms, concat names)
 153                       , fPrim    = \ty n ->return (Prim ty n,[])
 154                       }
 155         doSuspension freeNames ct mb_ty hval Nothing = do
 156           name <- atomicModifyIORef freeNames (\x->(tail x, head x))
 157           n <- newGrimName cms name
 158           let ty' = fromMaybe (error "unexpected") mb_ty
 159           return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)])
 160
 161
 162 --  A custom Term printer to enable the use of Show instances
 163 printTerm cms@(Session ref) = cPprTerm cPpr
 164  where
 165   cPpr = \p-> cPprShowable : cPprTermBase p
 166   cPprShowable prec t@Term{ty=ty, dc=dc, val=val} = do
 167     let hasType = isEmptyVarSet (tyVarsOfType ty)  -- redundant
 168         isEvaled = isFullyEvaluatedTerm t
 169     if not isEvaled -- || not hasType
 170      then return Nothing
 171      else do
 172         hsc_env <- readIORef ref
 173         dflags  <- GHC.getSessionDynFlags cms
 174         do
 175            (new_env, bname) <- bindToFreshName hsc_env ty "showme"
 176            writeIORef ref (new_env)
 177            let noop_log _ _ _ _ = return ()
 178                expr = "show " ++ showSDoc (ppr bname)
 179            GHC.setSessionDynFlags cms dflags{log_action=noop_log}
 180            mb_txt <- withExtendedLinkEnv [(bname, val)]
 181                                          (GHC.compileExpr cms expr)
 182            let myprec = 9 -- TODO Infix constructors
 183            case mb_txt of
 184              Just txt -> return . Just . text . unsafeCoerce#
 185                            $ txt
 186              Nothing  -> return Nothing
 187          `finally` do
 188            writeIORef ref hsc_env
 189            GHC.setSessionDynFlags cms dflags
 190
 191   bindToFreshName hsc_env ty userName = do
 192     name <- newGrimName cms userName
 193     let ictxt    = hsc_IC hsc_env
 194         rn_env   = ic_rn_local_env ictxt
 195         type_env = ic_type_env ictxt
 196         id       = mkGlobalId VanillaGlobal name ty vanillaIdInfo
 197         new_type_env = extendTypeEnv type_env (AnId id)
 198         new_rn_env   = extendLocalRdrEnv rn_env [name]
 199         new_ic       = ictxt { ic_rn_local_env = new_rn_env,
 200                                ic_type_env     = new_type_env }
 201     return (hsc_env {hsc_IC = new_ic }, name)
 202
 203 --    Create new uniques and give them sequentially numbered names
 204 --    newGrimName :: Session -> String -> IO Name
 205 newGrimName cms userName  = do
 206     us <- mkSplitUniqSupply 'b'
 207     let unique  = uniqFromSupply us
 208         occname = mkOccName varName userName
 209         name    = mkInternalName unique occname noSrcLoc
 210     return name
 211
 212 -- | The inverse function. Strip the GHC.Base.Unknowns in the type of the id, they correspond to tyvars. The caller must provide an infinite list of fresh names
 213 stripUnknowns :: [Name] -> Id -> Id
 214 stripUnknowns names id = setIdType id . fst . go names . idType
 215                            $ id
 216  where
 217    go tyvarsNames@(v:vv) ty
 218     | Just (ty1,ty2) <- splitFunTy_maybe ty = let
 219                (ty1',vv') = go tyvarsNames ty1
 220                (ty2',vv'')= go vv' ty2
 221                in (mkFunTy ty1' ty2', vv'')
 222     | Just (ty1,ty2) <- splitAppTy_maybe ty = let
 223                (ty1',vv') = go tyvarsNames ty1
 224                (ty2',vv'')= go vv' ty2
 225                in (mkAppTy ty1' ty2', vv'')
 226     | Just (tycon, args) <- splitTyConApp_maybe ty
 227     , Just (tycon', vv') <- (fixTycon tycon tyvarsNames)
 228     , (args',vv'') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg
 229                                              in (arg':aa,vv'))
 230                             ([],vv') args
 231     = (mkAppTys tycon' args',vv'')
 232     | Just (tycon, args) <- splitTyConApp_maybe ty
 233     , (args',vv') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg
 234                                             in (arg':aa,vv'))
 235                            ([],tyvarsNames) args
 236     = (mkTyConApp tycon args',vv')
 237     | otherwise = (ty, tyvarsNames)
 238     where  fixTycon tycon (v:vv) = do
 239                k <- lookup (tyConName tycon) kinds
 240                return (mkTyVarTy$ mkTyVar v k, vv)
 241            kinds = [ (unknownTyConName, liftedTypeKind)
 242                    , (unknown1TyConName, kind1)
 243                    , (unknown2TyConName, kind2)
 244                    , (unknown3TyConName, kind3)]
 245            kind1 = mkArrowKind liftedTypeKind liftedTypeKind
 246            kind2 = mkArrowKind kind1 liftedTypeKind
 247            kind3 = mkArrowKind kind2 liftedTypeKind
 248
 249 instantiateTyVarsToUnknown :: Session -> Type -> IO Type
 250 instantiateTyVarsToUnknown (Session ref) ty
 251   = do hsc_env <- readIORef ref
 252        DebuggerTys.instantiateTyVarsToUnknown hsc_env ty