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