compiler/ghci/Debugger.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- GHCi Interactive debugging commands
   4 --
   5 -- Pepe Iborra (supported by Google SoC) 2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module Debugger (pprintClosureCommand, instantiateTyVarsToUnknown) where
  10
  11 import Linker
  12 import RtClosureInspect
  13
  14 import PrelNames
  15 import HscTypes
  16 import IdInfo
  17 --import Id
  18 import Var hiding ( varName )
  19 import VarSet
  20 import VarEnv
  21 import Name
  22 import NameEnv
  23 import RdrName
  24 import UniqSupply
  25 import Type
  26 import TyCon
  27 import DataCon
  28 import TcGadt
  29 import GHC
  30 import GhciMonad
  31
  32 import Outputable
  33 import Pretty                    ( Mode(..), showDocWith )
  34 import FastString
  35 import SrcLoc
  36
  37 import Control.Exception
  38 import Control.Monad
  39 import Data.List
  40 import Data.Maybe
  41 import Data.IORef
  42
  43 import System.IO
  44 import GHC.Exts
  45
  46 #include "HsVersions.h"
  47
  48 -------------------------------------
  49 -- | The :print & friends commands
  50 -------------------------------------
  51 pprintClosureCommand :: Bool -> Bool -> String -> GHCi ()
  52 pprintClosureCommand bindThings force str = do
  53   cms <- getSession
  54   newvarsNames <- io$ do
  55            uniques <- liftM uniqsFromSupply (mkSplitUniqSupply 'q')
  56            return$ map (\u-> (mkSysTvName u (mkFastString "a"))) uniques
  57   mb_ids  <- io$ mapM (cleanUp cms newvarsNames) (words str)
  58   mb_new_ids <- mapM (io . go cms) (catMaybes mb_ids)
  59   io$ updateIds cms (catMaybes mb_new_ids)
  60  where
  61    -- Find the Id, clean up 'Unknowns'
  62    cleanUp :: Session -> [Name] -> String -> IO (Maybe Id)
  63    cleanUp cms newNames str = do
  64      tythings <- GHC.parseName cms str >>= mapM (GHC.lookupName cms)
  65      return$ listToMaybe (map (stripUnknowns newNames)
  66                               [ i | Just (AnId i) <- tythings])
  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 Id)
  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  <- pprTerm 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      -- Note how we need the Unknown-clear type returned by obtainTerm
  83        let Just reconstructedType = termType term
  84        new_type  <- instantiateTyVarsToUnknown cms
  85                     (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       concrete_tys    <- mapM (instantiateTyVarsToUnknown cms) tys
 129       let ids = [ mkGlobalId VanillaGlobal name ty vanillaIdInfo
 130                   | (name,ty) <- zip names concrete_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 pprTerm cms@(Session ref) = customPrintTerm customPrint
 160  where
 161   customPrint = \p-> customPrintShowable : customPrintTermBase p
 162   customPrintShowable 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            case mb_txt of
 179              Just txt -> return . Just . text . unsafeCoerce# $ txt
 180              Nothing  -> return Nothing
 181          `finally` do
 182            writeIORef ref hsc_env
 183            GHC.setSessionDynFlags cms dflags
 184
 185   bindToFreshName hsc_env ty userName = do
 186     name <- newGrimName cms userName
 187     let ictxt    = hsc_IC hsc_env
 188         rn_env   = ic_rn_local_env ictxt
 189         type_env = ic_type_env ictxt
 190         id       = mkGlobalId VanillaGlobal name ty vanillaIdInfo
 191         new_type_env = extendTypeEnv type_env (AnId id)
 192         new_rn_env   = extendLocalRdrEnv rn_env [name]
 193         new_ic       = ictxt { ic_rn_local_env = new_rn_env,
 194                                ic_type_env     = new_type_env }
 195     return (hsc_env {hsc_IC = new_ic }, name)
 196
 197 --    Create new uniques and give them sequentially numbered names
 198 --    newGrimName :: Session -> String -> IO Name
 199 newGrimName cms userName  = do
 200     us <- mkSplitUniqSupply 'b'
 201     let unique  = uniqFromSupply us
 202         occname = mkOccName varName userName
 203         name    = mkInternalName unique occname noSrcLoc
 204     return name
 205
 206 ----------------------------------------------------------------------------
 207 -- | Replace all the tyvars in a Term with the opaque type GHC.Base.Unknown
 208 ----------------------------------------------------------------------------
 209 instantiateTyVarsToUnknown :: Session -> Type -> IO Type
 210 instantiateTyVarsToUnknown cms ty
 211 -- We have a GADT, so just fix its tyvars
 212     | Just (tycon, args) <- splitTyConApp_maybe ty
 213     , tycon /= funTyCon
 214     , isGADT tycon
 215     = mapM fixTyVars args >>= return . mkTyConApp tycon
 216 -- We have a regular TyCon, so map recursively to its args
 217     | Just (tycon, args) <- splitTyConApp_maybe ty
 218     , tycon /= funTyCon
 219     = do unknownTyVar <- unknownTV
 220          args' <- mapM (instantiateTyVarsToUnknown cms) args
 221          return$ mkTyConApp tycon args'
 222 -- we have a tyvar of kind *
 223     | Just tyvar <- getTyVar_maybe ty
 224     , ([],_) <- splitKindFunTys (tyVarKind tyvar)
 225     = unknownTV
 226 -- we have a higher kind tyvar, so insert an unknown of the appropriate kind
 227     | Just tyvar <- getTyVar_maybe ty
 228     , (args,_) <- splitKindFunTys (tyVarKind tyvar)
 229     = liftM mkTyConTy $ unknownTC !! length args
 230 -- Base case
 231     | otherwise    = return ty
 232
 233  where unknownTV = do
 234          Just (ATyCon unknown_tc) <- lookupName cms unknownTyConName
 235          return$ mkTyConTy unknown_tc
 236        unknownTC = [undefined, unknownTC1, unknownTC2, unknownTC3]
 237        unknownTC1 = do
 238          Just (ATyCon unknown_tc) <- lookupName cms unknown1TyConName
 239          return unknown_tc
 240        unknownTC2 = do
 241          Just (ATyCon unknown_tc) <- lookupName cms unknown2TyConName
 242          return unknown_tc
 243        unknownTC3 = do
 244          Just (ATyCon unknown_tc) <- lookupName cms unknown3TyConName
 245          return unknown_tc
 246 --       isGADT ty | pprTrace' "isGADT" (ppr ty <> colon <> ppr(isGadtSyntaxTyCon ty)) False = undefined
 247        isGADT tc | Just dcs <- tyConDataCons_maybe tc = any (not . null . dataConEqSpec) dcs
 248                  | otherwise = False
 249        fixTyVars ty
 250            | Just (tycon, args) <- splitTyConApp_maybe ty
 251            = mapM fixTyVars args >>= return . mkTyConApp tycon
 252 -- Fix the tyvar so that the interactive environment doesn't choke on it TODO
 253            | Just tv <- getTyVar_maybe ty = return ty --TODO
 254            | otherwise = return ty
 255
 256 -- | 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
 257 stripUnknowns :: [Name] -> Id -> Id
 258 stripUnknowns names id = setIdType id . fst . go names . idType
 259                            $ id
 260  where
 261    go tyvarsNames@(v:vv) ty
 262     | Just (ty1,ty2) <- splitFunTy_maybe ty = let
 263                (ty1',vv') = go tyvarsNames ty1
 264                (ty2',vv'')= go vv' ty2
 265                in (mkFunTy ty1' ty2', vv'')
 266     | Just (ty1,ty2) <- splitAppTy_maybe ty = let
 267                (ty1',vv') = go tyvarsNames ty1
 268                (ty2',vv'')= go vv' ty2
 269                in (mkAppTy ty1' ty2', vv'')
 270     | Just (tycon, args) <- splitTyConApp_maybe ty
 271     , Just (tycon', vv') <- (fixTycon tycon tyvarsNames)
 272     , (args',vv'') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg
 273                                              in (arg':aa,vv'))
 274                             ([],vv') args
 275     = (mkAppTys tycon' args',vv'')
 276     | Just (tycon, args) <- splitTyConApp_maybe ty
 277     , (args',vv') <- foldr (\arg (aa,vv) -> let (arg',vv') = go vv' arg
 278                                             in (arg':aa,vv'))
 279                            ([],tyvarsNames) args
 280     = (mkTyConApp tycon args',vv')
 281     | otherwise = (ty, tyvarsNames)
 282     where  fixTycon tycon (v:vv) = do
 283                k <- lookup (tyConName tycon) kinds
 284                return (mkTyVarTy$ mkTyVar v k, vv)
 285            kinds = [ (unknownTyConName, liftedTypeKind)
 286                    , (unknown1TyConName, kind1)
 287                    , (unknown2TyConName, kind2)
 288                    , (unknown3TyConName, kind3)]
 289            kind1 = mkArrowKind liftedTypeKind liftedTypeKind
 290            kind2 = mkArrowKind kind1 liftedTypeKind
 291            kind3 = mkArrowKind kind2 liftedTypeKind