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