compiler/ghci/RtClosureInspect.hs

   1 -----------------------------------------------------------------------------\r
   2 --\r
   3 -- GHC Interactive support for inspecting arbitrary closures at runtime\r
   4 --\r
   5 -- Pepe Iborra (supported by Google SoC) 2006\r
   6 --\r
   7 -----------------------------------------------------------------------------\r
   8 \r
   9 module RtClosureInspect(\r
  10   \r
  11      cvObtainTerm,       -- :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term\r
  12 \r
  13      AddressEnv(..), \r
  14      DataConEnv,\r
  15      extendAddressEnvList, \r
  16      elemAddressEnv, \r
  17      delFromAddressEnv, \r
  18      emptyAddressEnv, \r
  19      lookupAddressEnv, \r
  20 \r
  21      ClosureType(..), \r
  22      getClosureData, \r
  23      Closure ( tipe, infoTable, ptrs, nonPtrs ), \r
  24      getClosureType, \r
  25      isConstr, \r
  26      isIndirection,\r
  27      getInfoTablePtr, \r
  28 \r
  29      Term(..), \r
  30      printTerm, \r
  31      customPrintTerm, \r
  32      customPrintTermBase,\r
  33      termType,\r
  34      foldTerm, \r
  35      TermFold(..), \r
  36      idTermFold, \r
  37      idTermFoldM,\r
  38      isFullyEvaluated, \r
  39      isPointed,\r
  40      isFullyEvaluatedTerm,\r
  41 --     unsafeDeepSeq, \r
  42  ) where \r
  43 \r
  44 #include "HsVersions.h"\r
  45 \r
  46 import ByteCodeItbls    ( StgInfoTable )\r
  47 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )\r
  48 import ByteCodeLink     ( HValue )\r
  49 import HscTypes         ( HscEnv )\r
  50 \r
  51 import DataCon          \r
  52 import Type             \r
  53 import TcRnMonad\r
  54 import TcType\r
  55 import TcMType\r
  56 import TcUnify\r
  57 import TcGadt\r
  58 import DriverPhases\r
  59 import TyCon            \r
  60 import Var\r
  61 import Name \r
  62 import Unique\r
  63 import UniqSupply\r
  64 import Var              ( setVarUnique, mkTyVar, tyVarKind, setTyVarKind )\r
  65 import VarEnv           ( mkVarEnv )\r
  66 import OccName          ( emptyTidyOccEnv )\r
  67 import VarSet           ( VarSet, mkVarSet, varSetElems, unionVarSets )\r
  68 import Unique           ( getUnique, incrUnique )\r
  69 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )\r
  70 \r
  71 import TysPrim          \r
  72 import PrelNames\r
  73 import TysWiredIn\r
  74 \r
  75 import Constants        ( wORD_SIZE )\r
  76 import FastString       ( mkFastString )\r
  77 import Outputable\r
  78 import Maybes\r
  79 import Panic\r
  80 import FiniteMap\r
  81 \r
  82 import GHC.Arr          ( Array(..) )\r
  83 import GHC.Ptr          ( Ptr(..), castPtr )\r
  84 import GHC.Exts         \r
  85 import GHC.Int          ( Int32(..),  Int64(..) )\r
  86 import GHC.Word         ( Word32(..), Word64(..) )\r
  87 \r
  88 import Control.Monad    ( liftM, liftM2, msum )\r
  89 import Data.Maybe\r
  90 import Data.Array.Base\r
  91 import Data.List        ( partition )\r
  92 import Foreign.Storable\r
  93 import Foreign          ( unsafePerformIO )\r
  94 \r
  95 ---------------------------------------------\r
  96 -- * A representation of semi evaluated Terms\r
  97 ---------------------------------------------\r
  98 {-\r
  99   A few examples in this representation:\r
 100 \r
 101   > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]\r
 102 \r
 103   > (('a',_,_),_,('b',_,_)) = \r
 104       Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))\r
 105           [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Thunk, Thunk]\r
 106           , Thunk\r
 107           , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Thunk, Thunk]]\r
 108 -}\r
 109 \r
 110 data Term = Term { ty        :: Type \r
 111                  , dc        :: DataCon \r
 112                  , val       :: HValue \r
 113                  , subTerms  :: [Term] }\r
 114 \r
 115           | Prim { ty        :: Type\r
 116                  , value     :: String }\r
 117 \r
 118           | Suspension { ctype    :: ClosureType\r
 119                        , mb_ty    :: Maybe Type\r
 120                        , val      :: HValue\r
 121                        , bound_to :: Maybe Name   -- Useful for printing\r
 122                        }\r
 123 \r
 124 isTerm Term{} = True\r
 125 isTerm   _    = False\r
 126 isSuspension Suspension{} = True\r
 127 isSuspension      _       = False\r
 128 isPrim Prim{} = True\r
 129 isPrim   _    = False\r
 130 \r
 131 termType t@(Suspension {}) = mb_ty t\r
 132 termType t = Just$ ty t\r
 133 \r
 134 instance Outputable (Term) where\r
 135  ppr = head . customPrintTerm customPrintTermBase\r
 136 \r
 137 -------------------------------------------------------------------------\r
 138 -- Runtime Closure Datatype and functions for retrieving closure related stuff\r
 139 -------------------------------------------------------------------------\r
 140 data ClosureType = Constr \r
 141                  | Fun \r
 142                  | Thunk Int \r
 143                  | ThunkSelector\r
 144                  | Blackhole \r
 145                  | AP \r
 146                  | PAP \r
 147                  | Indirection Int \r
 148                  | Other Int\r
 149  deriving (Show, Eq)\r
 150 \r
 151 data Closure = Closure { tipe         :: ClosureType \r
 152                        , infoTable    :: StgInfoTable\r
 153                        , ptrs         :: Array Int HValue\r
 154                         -- What would be the type here? HValue is ok? Should I build a Ptr?\r
 155                        , nonPtrs      :: ByteArray# \r
 156                        }\r
 157 \r
 158 instance Outputable ClosureType where\r
 159   ppr = text . show \r
 160 \r
 161 getInfoTablePtr :: a -> Ptr StgInfoTable\r
 162 getInfoTablePtr x = \r
 163     case infoPtr# x of\r
 164       itbl_ptr -> castPtr ( Ptr itbl_ptr )\r
 165 \r
 166 getClosureType :: a -> IO ClosureType\r
 167 getClosureType = liftM (readCType . BCI.tipe ) . peek . getInfoTablePtr\r
 168 \r
 169 #include "../includes/ClosureTypes.h"\r
 170 \r
 171 aP_CODE = AP\r
 172 pAP_CODE = PAP\r
 173 #undef AP\r
 174 #undef PAP\r
 175 \r
 176 getClosureData :: a -> IO Closure\r
 177 getClosureData a = do\r
 178    itbl <- peek (getInfoTablePtr a)\r
 179    let tipe = readCType (BCI.tipe itbl)\r
 180    case closurePayload# a of \r
 181      (# ptrs, nptrs #) -> \r
 182            let elems = BCI.ptrs itbl \r
 183                ptrsList = Array 0 (fromIntegral$ elems) ptrs\r
 184            in ptrsList `seq` return (Closure tipe itbl ptrsList nptrs)\r
 185 \r
 186 readCType :: Integral a => a -> ClosureType\r
 187 readCType i\r
 188  | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr\r
 189  | i >= FUN    && i <= FUN_STATIC          = Fun\r
 190  | i >= THUNK  && i < THUNK_SELECTOR       = Thunk (fromIntegral i)\r
 191  | i == THUNK_SELECTOR                     = ThunkSelector\r
 192  | i == BLACKHOLE                          = Blackhole\r
 193  | i >= IND    && i <= IND_STATIC          = Indirection (fromIntegral i)\r
 194  | fromIntegral i == aP_CODE               = AP\r
 195  | fromIntegral i == pAP_CODE              = PAP\r
 196  | otherwise                               = Other (fromIntegral i)\r
 197 \r
 198 isConstr, isIndirection :: ClosureType -> Bool\r
 199 isConstr Constr = True\r
 200 isConstr    _   = False\r
 201 \r
 202 isIndirection (Indirection _) = True\r
 203 --isIndirection ThunkSelector = True\r
 204 isIndirection _ = False\r
 205 \r
 206 isFullyEvaluated :: a -> IO Bool\r
 207 isFullyEvaluated a = do \r
 208   closure <- getClosureData a \r
 209   case tipe closure of\r
 210     Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)\r
 211                  return$ and are_subs_evaluated\r
 212     otherwise -> return False\r
 213   where amapM f = sequence . amap' f\r
 214 \r
 215 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of\r
 216                                    (# e #) -> f e)\r
 217                                 [0 .. i - i0]\r
 218 \r
 219 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it\r
 220 {-\r
 221 unsafeDeepSeq :: a -> b -> b\r
 222 unsafeDeepSeq = unsafeDeepSeq1 2\r
 223  where unsafeDeepSeq1 0 a b = seq a $! b\r
 224        unsafeDeepSeq1 i a b                -- 1st case avoids infinite loops for non reducible thunks\r
 225         | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b     \r
 226      -- | unsafePerformIO (isFullyEvaluated a) = b\r
 227         | otherwise = case unsafePerformIO (getClosureData a) of\r
 228                         closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)\r
 229         where tipe = unsafePerformIO (getClosureType a)\r
 230 -}\r
 231 isPointed :: Type -> Bool\r
 232 isPointed t | Just (t, _) <- splitTyConApp_maybe t = not$ isUnliftedTypeKind (tyConKind t)\r
 233 isPointed _ = True\r
 234 \r
 235 #define MKDECODER(offset,cons,builder) (offset, show$ cons (builder addr 0#))\r
 236 \r
 237 extractUnboxed  :: [Type] -> ByteArray# -> [String]\r
 238 extractUnboxed tt ba = helper tt (byteArrayContents# ba)\r
 239    where helper :: [Type] -> Addr# -> [String]\r
 240          helper (t:tt) addr \r
 241           | Just ( tycon,_) <- splitTyConApp_maybe t \r
 242           =  let (offset, txt) = decode tycon addr\r
 243                  (I# word_offset)   = offset*wORD_SIZE\r
 244              in txt : helper tt (plusAddr# addr word_offset)\r
 245           | otherwise \r
 246           = -- ["extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)]\r
 247             panic$ "extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)\r
 248          helper [] addr = []\r
 249          decode :: TyCon -> Addr# -> (Int, String)\r
 250          decode t addr                             \r
 251            | t == charPrimTyCon   = MKDECODER(1,C#,indexCharOffAddr#)\r
 252            | t == intPrimTyCon    = MKDECODER(1,I#,indexIntOffAddr#)\r
 253            | t == wordPrimTyCon   = MKDECODER(1,W#,indexWordOffAddr#)\r
 254            | t == floatPrimTyCon  = MKDECODER(1,F#,indexFloatOffAddr#)\r
 255            | t == doublePrimTyCon = MKDECODER(2,D#,indexDoubleOffAddr#)\r
 256            | t == int32PrimTyCon  = MKDECODER(1,I32#,indexInt32OffAddr#)\r
 257            | t == word32PrimTyCon = MKDECODER(1,W32#,indexWord32OffAddr#)\r
 258            | t == int64PrimTyCon  = MKDECODER(2,I64#,indexInt64OffAddr#)\r
 259            | t == word64PrimTyCon = MKDECODER(2,W64#,indexWord64OffAddr#)\r
 260            | t == addrPrimTyCon   = MKDECODER(1,I#,(\x off-> addr2Int# (indexAddrOffAddr# x off)))  --OPT Improve the presentation of addresses\r
 261            | t == stablePtrPrimTyCon  = (1, "<stablePtr>")\r
 262            | t == stableNamePrimTyCon = (1, "<stableName>")\r
 263            | t == statePrimTyCon      = (1, "<statethread>")\r
 264            | t == realWorldTyCon      = (1, "<realworld>")\r
 265            | t == threadIdPrimTyCon   = (1, "<ThreadId>")\r
 266            | t == weakPrimTyCon       = (1, "<Weak>")\r
 267            | t == arrayPrimTyCon      = (1,"<array>")\r
 268            | t == byteArrayPrimTyCon  = (1,"<bytearray>")\r
 269            | t == mutableArrayPrimTyCon = (1, "<mutableArray>")\r
 270            | t == mutableByteArrayPrimTyCon = (1, "<mutableByteArray>")\r
 271            | t == mutVarPrimTyCon= (1, "<mutVar>")\r
 272            | t == mVarPrimTyCon  = (1, "<mVar>")\r
 273            | t == tVarPrimTyCon  = (1, "<tVar>")\r
 274            | otherwise = (1, showSDoc (char '<' <> ppr t <> char '>')) \r
 275                  -- We cannot know the right offset in the otherwise case, so 1 is just a wild dangerous guess!\r
 276            -- TODO: Improve the offset handling in decode (make it machine dependant)\r
 277 \r
 278 -----------------------------------\r
 279 -- Boilerplate Fold code for Term\r
 280 -----------------------------------\r
 281 \r
 282 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a\r
 283                            , fPrim :: Type -> String -> a\r
 284                            , fSuspension :: ClosureType -> Maybe Type -> HValue -> Maybe Name -> a\r
 285                            }\r
 286 \r
 287 foldTerm :: TermFold a -> Term -> a\r
 288 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)\r
 289 foldTerm tf (Prim ty    v   ) = fPrim tf ty v\r
 290 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b\r
 291 \r
 292 idTermFold :: TermFold Term\r
 293 idTermFold = TermFold {\r
 294               fTerm = Term,\r
 295               fPrim = Prim,\r
 296               fSuspension = Suspension\r
 297                       }\r
 298 idTermFoldM :: Monad m => TermFold (m Term)\r
 299 idTermFoldM = TermFold {\r
 300               fTerm       = \ty dc v tt -> sequence tt >>= return . Term ty dc v,\r
 301               fPrim       = (return.). Prim,\r
 302               fSuspension = (((return.).).). Suspension\r
 303                        }\r
 304 \r
 305 ----------------------------------\r
 306 -- Pretty printing of terms\r
 307 ----------------------------------\r
 308 \r
 309 parensCond True  = parens\r
 310 parensCond False = id\r
 311 app_prec::Int\r
 312 app_prec = 10\r
 313 \r
 314 printTerm :: Term -> SDoc\r
 315 printTerm Prim{value=value} = text value \r
 316 printTerm t@Term{} = printTerm1 0 t \r
 317 printTerm Suspension{bound_to=Nothing} =  char '_' -- <> ppr ct <> char '_'\r
 318 printTerm Suspension{mb_ty=Just ty, bound_to=Just n} =\r
 319   parens$ ppr n <> text "::" <> ppr ty \r
 320 \r
 321 printTerm1 p Term{dc=dc, subTerms=tt} \r
 322 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt \r
 323   = parens (printTerm1 True t1 <+> ppr dc <+> printTerm1 True ppr t2) \r
 324     <+> hsep (map (printTerm1 True) tt) \r
 325 -}\r
 326   | null tt   = ppr dc\r
 327   | otherwise = parensCond (p > app_prec) \r
 328                      (ppr dc <+> sep (map (printTerm1 (app_prec+1)) tt))\r
 329 \r
 330   where fixity   = undefined \r
 331 \r
 332 printTerm1 _ t = printTerm t\r
 333 \r
 334 customPrintTerm :: Monad m => ((Int->Term->m SDoc)->[Term->m (Maybe SDoc)]) -> Term -> m SDoc\r
 335 customPrintTerm custom = let \r
 336 --  go :: Monad m => Int -> Term -> m SDoc\r
 337   go prec t@Term{subTerms=tt, dc=dc} = do\r
 338     mb_customDocs <- sequence$ sequence (custom go) t  -- Inner sequence is List monad\r
 339     case msum mb_customDocs of        -- msum is in Maybe monad\r
 340       Just doc -> return$ parensCond (prec>app_prec+1) doc\r
 341 --    | dataConIsInfix dc, (t1:t2:tt') <- tt =\r
 342       Nothing  -> do pprSubterms <- mapM (go (app_prec+1)) tt\r
 343                      return$ parensCond (prec>app_prec+1) \r
 344                                         (ppr dc <+> sep pprSubterms)\r
 345   go _ t = return$ printTerm t\r
 346   in go 0 \r
 347    where fixity = undefined \r
 348 \r
 349 customPrintTermBase :: Monad m => (Int->Term-> m SDoc)->[Term->m (Maybe SDoc)]\r
 350 customPrintTermBase showP =\r
 351   [ \r
 352     test isTupleDC (liftM (parens . cat . punctuate comma) . mapM (showP 0) . subTerms)\r
 353   , test (isDC consDataCon) (\Term{subTerms=[h,t]} -> doList h t)\r
 354   , test (isDC intDataCon)  (coerceShow$ \(a::Int)->a)\r
 355   , test (isDC charDataCon) (coerceShow$ \(a::Char)->a)\r
 356 --  , test (isDC wordDataCon) (coerceShow$ \(a::Word)->a)\r
 357   , test (isDC floatDataCon) (coerceShow$ \(a::Float)->a)\r
 358   , test (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)\r
 359   , test isIntegerDC (coerceShow$ \(a::Integer)->a)\r
 360   ] \r
 361      where test pred f t = if pred t then liftM Just (f t) else return Nothing\r
 362            isIntegerDC Term{dc=dc} = \r
 363               dataConName dc `elem` [ smallIntegerDataConName\r
 364                                     , largeIntegerDataConName] \r
 365            isTupleDC Term{dc=dc}   = dc `elem` snd (unzip (elems boxedTupleArr))\r
 366            isDC a_dc Term{dc=dc}   = a_dc == dc\r
 367            coerceShow f Term{val=val} = return . text . show . f . unsafeCoerce# $ val\r
 368            --TODO pprinting of list terms is not lazy\r
 369            doList h t = do\r
 370                let elems = h : getListTerms t\r
 371                    isConsLast = isSuspension (last elems) && \r
 372                                 (mb_ty$ last elems) /= (termType h)\r
 373                init <- mapM (showP 0) (init elems) \r
 374                last0 <- showP 0 (last elems)\r
 375                let last = case length elems of \r
 376                             1 -> last0 \r
 377                             _ | isConsLast -> text " | " <> last0\r
 378                             _ -> comma <> last0\r
 379                return$ brackets (cat (punctuate comma init ++ [last]))\r
 380 \r
 381                 where Just a /= Just b = not (a `coreEqType` b)\r
 382                       _      /=   _    = True\r
 383                       getListTerms Term{subTerms=[h,t]} = h : getListTerms t\r
 384                       getListTerms t@Term{subTerms=[]}  = []\r
 385                       getListTerms t@Suspension{}       = [t]\r
 386                       getListTerms t = pprPanic "getListTerms" (ppr t)\r
 387 \r
 388 isFullyEvaluatedTerm :: Term -> Bool\r
 389 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt\r
 390 isFullyEvaluatedTerm Suspension {}      = False\r
 391 isFullyEvaluatedTerm Prim {}            = True\r
 392 \r
 393 \r
 394 -----------------------------------\r
 395 -- Type Reconstruction\r
 396 -----------------------------------\r
 397 \r
 398 -- The Type Reconstruction monad\r
 399 type TR a = TcM a\r
 400 \r
 401 runTR :: HscEnv -> TR Term -> IO Term\r
 402 runTR hsc_env c = do \r
 403   mb_term <- initTcPrintErrors hsc_env iNTERACTIVE (c >>= zonkTerm)\r
 404   case mb_term of \r
 405     Nothing -> panic "Can't unify"\r
 406     Just term -> return term\r
 407 \r
 408 trIO :: IO a -> TR a \r
 409 trIO = liftTcM . ioToTcRn\r
 410 \r
 411 addConstraint :: TcType -> TcType -> TR ()\r
 412 addConstraint t1 t2  = congruenceNewtypes t1 t2 >> unifyType t1 t2\r
 413 \r
 414 -- A parallel fold over a Type value, replacing\r
 415 -- in the right side reptypes for newtypes as found in the lhs\r
 416 -- Sadly it doesn't cover all the possibilities. It does not always manage\r
 417 -- to recover the highest level type. See test print016 for an example\r
 418 congruenceNewtypes ::  TcType -> TcType -> TcM TcType\r
 419 congruenceNewtypes lhs rhs\r
 420 --    | pprTrace "Congruence" (ppr lhs $$ ppr rhs) False = undefined\r
 421  -- We have a tctyvar at the other side\r
 422     | Just tv <- getTyVar_maybe rhs \r
 423 --    , trace "congruence, entering tyvar" True\r
 424     = recoverM (return rhs) $ do  \r
 425          Indirect ty_v <- readMetaTyVar tv\r
 426          newtyped_tytv <- congruenceNewtypes lhs ty_v\r
 427          writeMutVar (metaTvRef tv) (Indirect newtyped_tytv)\r
 428          return newtyped_tytv\r
 429 -- We have a function type: go on inductively\r
 430     | Just (r1,r2) <- splitFunTy_maybe rhs\r
 431     , Just (l1,l2) <- splitFunTy_maybe lhs\r
 432     = liftM2 mkFunTy ( congruenceNewtypes l1 r1)\r
 433                       (congruenceNewtypes l2 r2)\r
 434 -- There is a newtype at the top level tycon and we can manage it\r
 435     | Just (tycon, args)    <- splitNewTyConApp_maybe lhs\r
 436     , isNewTyCon tycon\r
 437     , (tvs, realtipe)       <- newTyConRep tycon\r
 438     =   case tcUnifyTys (const BindMe) [realtipe] [rhs] of\r
 439           Just subst -> \r
 440                 let tvs' = substTys subst (map mkTyVarTy tvs) in\r
 441                 liftM (mkTyConApp tycon) (zipWithM congruenceNewtypes args tvs')\r
 442           otherwise -> panic "congruenceNewtypes: Can't unify a newtype"\r
 443                                              \r
 444 -- We have a TyconApp: go on inductively\r
 445     | Just (tycon, args)     <- splitNewTyConApp_maybe lhs\r
 446     , Just (tycon_v, args_v) <- splitNewTyConApp_maybe rhs\r
 447     = liftM (mkTyConApp tycon_v) (zipWithM congruenceNewtypes args args_v)\r
 448 \r
 449     | otherwise = return rhs\r
 450 \r
 451 \r
 452 newVar :: Kind -> TR TcTyVar\r
 453 newVar = liftTcM . newFlexiTyVar\r
 454 \r
 455 liftTcM = id\r
 456 \r
 457 instScheme :: Type -> TR TcType\r
 458 instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty)\r
 459     where fst3 (x,y,z) = x\r
 460           trd  (x,y,z) = z\r
 461 \r
 462 cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term\r
 463 cvObtainTerm hsc_env force mb_ty a = \r
 464  -- Obtain the term and tidy the type before returning it\r
 465      cvObtainTerm1 hsc_env force mb_ty a >>= return . tidyTypes \r
 466    where \r
 467          tidyTypes = foldTerm idTermFold {\r
 468             fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,\r
 469             fSuspension = \ct mb_ty hval n -> \r
 470                           Suspension ct (fmap tidy mb_ty) hval n\r
 471             }\r
 472          tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty  \r
 473          tidyVarEnv ty = \r
 474              mkVarEnv$ [ (v, setTyVarName v (tyVarName tv))\r
 475                          | (tv,v) <- zip alphaTyVars vars]\r
 476              where vars = varSetElems$ tyVarsOfType ty\r
 477 \r
 478 cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term\r
 479 cvObtainTerm1 hsc_env force mb_ty hval\r
 480   | Nothing <- mb_ty = runTR hsc_env . go argTypeKind $ hval\r
 481   | Just ty <- mb_ty = runTR hsc_env $ do\r
 482                  term <- go argTypeKind hval\r
 483                  ty'  <- instScheme ty\r
 484                  addConstraint ty' (fromMaybe (error "by definition") \r
 485                                               (termType term)) \r
 486                  return term\r
 487     where \r
 488   go k a = do \r
 489     ctype <- trIO$ getClosureType a\r
 490     case ctype of\r
 491 -- Thunks we may want to force\r
 492       Thunk _ | force -> seq a $ go k a\r
 493 -- We always follow indirections \r
 494       _       | isIndirection ctype \r
 495                       -> do\r
 496         clos   <- trIO$ getClosureData a\r
 497 --      dflags <- getSessionDynFlags session\r
 498 --      debugTraceMsg dflags 2 (text "Following an indirection")\r
 499         go k $! (ptrs clos ! 0)\r
 500  -- The interesting case\r
 501       Constr -> do\r
 502         m_dc <- trIO$ tcRnRecoverDataCon hsc_env a\r
 503         case m_dc of\r
 504           Nothing -> panic "Can't find the DataCon for a term"\r
 505           Just dc -> do \r
 506             clos          <- trIO$ getClosureData a\r
 507             let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)\r
 508                 subTtypes  = drop extra_args (dataConRepArgTys dc)\r
 509                 (subTtypesP, subTtypesNP) = partition isPointed subTtypes\r
 510                 \r
 511             subTermsP <- mapM (\i->extractSubterm i (ptrs clos)\r
 512                                                     (subTtypesP!!(i-extra_args)))\r
 513                               [extra_args..extra_args + length subTtypesP - 1]\r
 514             let unboxeds   = extractUnboxed subTtypesNP (nonPtrs clos)\r
 515                 subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)      \r
 516                 subTerms   = reOrderTerms subTermsP subTermsNP subTtypes\r
 517             resType       <- liftM mkTyVarTy (newVar k)\r
 518             baseType      <- instScheme (dataConRepType dc)\r
 519             let myType     = mkFunTys (map (fromMaybe undefined . termType) \r
 520                                        subTerms) \r
 521                                   resType\r
 522             addConstraint baseType myType\r
 523             return (Term resType dc a subTerms)\r
 524 -- The otherwise case: can be a Thunk,AP,PAP,etc.\r
 525       otherwise -> do\r
 526          x <- liftM mkTyVarTy (newVar k)\r
 527          return (Suspension ctype (Just x) a Nothing)\r
 528 \r
 529 -- Access the array of pointers and recurse down. Needs to be done with\r
 530 -- care of no introducing a thunk! or go will fail to do its job \r
 531   extractSubterm (I# i#) ptrs ty = case ptrs of \r
 532                  (Array _ _ ptrs#) -> case indexArray# ptrs# i# of \r
 533                        (# e #) -> go (typeKind ty) e\r
 534 \r
 535 -- This is used to put together pointed and nonpointed subterms in the \r
 536 --  correct order.\r
 537   reOrderTerms _ _ [] = []\r
 538   reOrderTerms pointed unpointed (ty:tys) \r
 539    | isPointed ty = head pointed : reOrderTerms (tail pointed) unpointed tys\r
 540    | otherwise    = head unpointed : reOrderTerms pointed (tail unpointed) tys\r
 541 \r
 542 zonkTerm :: Term -> TcM Term\r
 543 zonkTerm = foldTerm idTermFoldM {\r
 544               fTerm = \ty dc v tt -> sequence tt      >>= \tt ->\r
 545                                      zonkTcType ty    >>= \ty' ->\r
 546                                      return (Term ty' dc v tt)\r
 547              ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->\r
 548                                           return (Suspension ct ty v b)}  \r
 549 \r
 550 {-\r
 551 Example of Type Reconstruction\r
 552 --------------------------------\r
 553 Suppose we have an existential type such as\r
 554 \r
 555 data Opaque = forall a. Opaque a\r
 556 \r
 557 And we have a term built as:\r
 558 \r
 559 t = Opaque (map Just [[1,1],[2,2]])\r
 560 \r
 561 The type of t as far as the typechecker goes is t :: Opaque\r
 562 If we seq the head of t, we obtain:\r
 563 \r
 564 t - O (_1::a) \r
 565 \r
 566 seq _1 ()\r
 567 \r
 568 t - O ( (_3::b) : (_4::[b]) ) \r
 569 \r
 570 seq _3 ()\r
 571 \r
 572 t - O ( (Just (_5::c)) : (_4::[b]) ) \r
 573 \r
 574 At this point, we know that b = (Maybe c)\r
 575 \r
 576 seq _5 ()\r
 577 \r
 578 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[b]) )\r
 579 \r
 580 At this point, we know that c = [d]\r
 581 \r
 582 seq _6 ()\r
 583 \r
 584 t - O ( (Just (1 : (_7::[d]) )) : (_4::[b]) )\r
 585 \r
 586 At this point, we know that d = Integer\r
 587 \r
 588 The fully reconstructed expressions, with propagation, would be:\r
 589 \r
 590 t - O ( (Just (_5::c)) : (_4::[Maybe c]) ) \r
 591 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[Maybe [d]]) )\r
 592 t - O ( (Just (1 : (_7::[Integer]) )) : (_4::[Maybe [Integer]]) )\r
 593 \r
 594 \r
 595 For reference, the type of the thing inside the opaque is \r
 596 map Just [[1,1],[2,2]] :: [Maybe [Integer]]\r
 597 \r
 598 NOTE: (Num t) contexts have been manually replaced by Integer for clarity\r
 599 -}\r
 600 \r
 601 --------------------------------------------------------------------\r
 602 -- The DataConEnv is used to store the addresses of datacons loaded\r
 603 -- via the dynamic linker\r
 604 --------------------------------------------------------------------\r
 605 \r
 606 type DataConEnv   = AddressEnv StgInfoTable\r
 607 \r
 608 -- Note that this AddressEnv and DataConEnv I wrote trying to follow \r
 609 -- conventions in ghc, but probably they make not much sense.\r
 610 \r
 611 newtype AddressEnv a = AE {aenv:: FiniteMap (Ptr a) Name}\r
 612   deriving (Outputable)\r
 613 \r
 614 emptyAddressEnv = AE emptyFM\r
 615 \r
 616 extendAddressEnvList  :: AddressEnv a -> [(Ptr a, Name)] -> AddressEnv a\r
 617 elemAddressEnv        :: Ptr a -> AddressEnv a -> Bool\r
 618 delFromAddressEnv     :: AddressEnv a -> Ptr a -> AddressEnv a\r
 619 nullAddressEnv        :: AddressEnv a -> Bool\r
 620 lookupAddressEnv       :: AddressEnv a -> Ptr a -> Maybe Name\r
 621 \r
 622 extendAddressEnvList  (AE env) = AE . addListToFM env \r
 623 elemAddressEnv   ptr  (AE env) = ptr `elemFM` env\r
 624 delFromAddressEnv     (AE env) = AE . delFromFM env\r
 625 nullAddressEnv                 = isEmptyFM . aenv\r
 626 lookupAddressEnv      (AE env) = lookupFM env\r
 627 \r
 628 \r
 629 instance Outputable (Ptr a) where\r
 630   ppr = text . show