compiler/ghci/RtClosureInspect.hs

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