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