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
  43      sigmaType
  44  ) where
  45
  46 #include "HsVersions.h"
  47
  48 import ByteCodeItbls    ( StgInfoTable )
  49 import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
  50 import ByteCodeLink     ( HValue )
  51 import HscTypes         ( HscEnv )
  52
  53 import DataCon
  54 import Type
  55 import TcRnMonad        ( TcM, initTcPrintErrors, ioToTcRn, recoverM, writeMutVar )
  56 import TcType
  57 import TcMType
  58 import TcUnify
  59 import TcGadt
  60 import TyCon
  61 import Var
  62 import Name
  63 import VarEnv
  64 import OccName
  65 import VarSet
  66 import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )
  67
  68 import TysPrim
  69 import PrelNames
  70 import TysWiredIn
  71
  72 import Constants        ( wORD_SIZE )
  73 import Outputable
  74 import Maybes
  75 import Panic
  76 import FiniteMap
  77
  78 import GHC.Arr          ( Array(..) )
  79 import GHC.Ptr          ( Ptr(..), castPtr )
  80 import GHC.Exts
  81 import GHC.Int          ( Int32(..),  Int64(..) )
  82 import GHC.Word         ( Word32(..), Word64(..) )
  83
  84 import Control.Monad
  85 import Data.Maybe
  86 import Data.Array.Base
  87 import Data.List        ( partition )
  88 import Foreign.Storable
  89
  90 ---------------------------------------------
  91 -- * A representation of semi evaluated Terms
  92 ---------------------------------------------
  93 {-
  94   A few examples in this representation:
  95
  96   > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]
  97
  98   > (('a',_,_),_,('b',_,_)) =
  99       Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
 100           [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Thunk, Thunk]
 101           , Thunk
 102           , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Thunk, Thunk]]
 103 -}
 104
 105 data Term = Term { ty        :: Type
 106                  , dc        :: DataCon
 107                  , val       :: HValue
 108                  , subTerms  :: [Term] }
 109
 110           | Prim { ty        :: Type
 111                  , value     :: String }
 112
 113           | Suspension { ctype    :: ClosureType
 114                        , mb_ty    :: Maybe Type
 115                        , val      :: HValue
 116                        , bound_to :: Maybe Name   -- Useful for printing
 117                        }
 118
 119 isTerm Term{} = True
 120 isTerm   _    = False
 121 isSuspension Suspension{} = True
 122 isSuspension      _       = False
 123 isPrim Prim{} = True
 124 isPrim   _    = False
 125
 126 termType t@(Suspension {}) = mb_ty t
 127 termType t = Just$ ty t
 128
 129 isFullyEvaluatedTerm :: Term -> Bool
 130 isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
 131 isFullyEvaluatedTerm Suspension {}      = False
 132 isFullyEvaluatedTerm Prim {}            = True
 133
 134 instance Outputable (Term) where
 135  ppr = head . customPrintTerm customPrintTermBase
 136
 137 -------------------------------------------------------------------------
 138 -- Runtime Closure Datatype and functions for retrieving closure related stuff
 139 -------------------------------------------------------------------------
 140 data ClosureType = Constr
 141                  | Fun
 142                  | Thunk Int
 143                  | ThunkSelector
 144                  | Blackhole
 145                  | AP
 146                  | PAP
 147                  | Indirection Int
 148                  | Other Int
 149  deriving (Show, Eq)
 150
 151 data Closure = Closure { tipe         :: ClosureType
 152                        , infoTable    :: StgInfoTable
 153                        , ptrs         :: Array Int HValue
 154                         -- What would be the type here? HValue is ok? Should I build a Ptr?
 155                        , nonPtrs      :: ByteArray#
 156                        }
 157
 158 instance Outputable ClosureType where
 159   ppr = text . show
 160
 161 getInfoTablePtr :: a -> Ptr StgInfoTable
 162 getInfoTablePtr x =
 163     case infoPtr# x of
 164       itbl_ptr -> castPtr ( Ptr itbl_ptr )
 165
 166 getClosureType :: a -> IO ClosureType
 167 getClosureType = liftM (readCType . BCI.tipe ) . peek . getInfoTablePtr
 168
 169 #include "../includes/ClosureTypes.h"
 170
 171 aP_CODE = AP
 172 pAP_CODE = PAP
 173 #undef AP
 174 #undef PAP
 175
 176 getClosureData :: a -> IO Closure
 177 getClosureData a = do
 178    itbl <- peek (getInfoTablePtr a)
 179    let tipe = readCType (BCI.tipe itbl)
 180    case closurePayload# a of
 181      (# ptrs, nptrs #) ->
 182            let elems = BCI.ptrs itbl
 183                ptrsList = Array 0 (fromIntegral$ elems) ptrs
 184            in ptrsList `seq` return (Closure tipe itbl ptrsList nptrs)
 185
 186 readCType :: Integral a => a -> ClosureType
 187 readCType i
 188  | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
 189  | i >= FUN    && i <= FUN_STATIC          = Fun
 190  | i >= THUNK  && i < THUNK_SELECTOR       = Thunk (fromIntegral i)
 191  | i == THUNK_SELECTOR                     = ThunkSelector
 192  | i == BLACKHOLE                          = Blackhole
 193  | i >= IND    && i <= IND_STATIC          = Indirection (fromIntegral i)
 194  | fromIntegral i == aP_CODE               = AP
 195  | fromIntegral i == pAP_CODE              = PAP
 196  | otherwise                               = Other (fromIntegral i)
 197
 198 isConstr, isIndirection :: ClosureType -> Bool
 199 isConstr Constr = True
 200 isConstr    _   = False
 201
 202 isIndirection (Indirection _) = True
 203 --isIndirection ThunkSelector = True
 204 isIndirection _ = False
 205
 206 isFullyEvaluated :: a -> IO Bool
 207 isFullyEvaluated a = do
 208   closure <- getClosureData a
 209   case tipe closure of
 210     Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
 211                  return$ and are_subs_evaluated
 212     otherwise -> return False
 213   where amapM f = sequence . amap' f
 214
 215 amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
 216                                    (# e #) -> f e)
 217                                 [0 .. i - i0]
 218
 219 -- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
 220 {-
 221 unsafeDeepSeq :: a -> b -> b
 222 unsafeDeepSeq = unsafeDeepSeq1 2
 223  where unsafeDeepSeq1 0 a b = seq a $! b
 224        unsafeDeepSeq1 i a b                -- 1st case avoids infinite loops for non reducible thunks
 225         | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b
 226      -- | unsafePerformIO (isFullyEvaluated a) = b
 227         | otherwise = case unsafePerformIO (getClosureData a) of
 228                         closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
 229         where tipe = unsafePerformIO (getClosureType a)
 230 -}
 231 isPointed :: Type -> Bool
 232 isPointed t | Just (t, _) <- splitTyConApp_maybe t = not$ isUnliftedTypeKind (tyConKind t)
 233 isPointed _ = True
 234
 235 #define MKDECODER(offset,cons,builder) (offset, show$ cons (builder addr 0#))
 236
 237 extractUnboxed  :: [Type] -> ByteArray# -> [String]
 238 extractUnboxed tt ba = helper tt (byteArrayContents# ba)
 239    where helper :: [Type] -> Addr# -> [String]
 240          helper (t:tt) addr
 241           | Just ( tycon,_) <- splitTyConApp_maybe t
 242           =  let (offset, txt) = decode tycon addr
 243                  (I# word_offset)   = offset*wORD_SIZE
 244              in txt : helper tt (plusAddr# addr word_offset)
 245           | otherwise
 246           = -- ["extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)]
 247             panic$ "extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)
 248          helper [] addr = []
 249          decode :: TyCon -> Addr# -> (Int, String)
 250          decode t addr
 251            | t == charPrimTyCon   = MKDECODER(1,C#,indexCharOffAddr#)
 252            | t == intPrimTyCon    = MKDECODER(1,I#,indexIntOffAddr#)
 253            | t == wordPrimTyCon   = MKDECODER(1,W#,indexWordOffAddr#)
 254            | t == floatPrimTyCon  = MKDECODER(1,F#,indexFloatOffAddr#)
 255            | t == doublePrimTyCon = MKDECODER(2,D#,indexDoubleOffAddr#)
 256            | t == int32PrimTyCon  = MKDECODER(1,I32#,indexInt32OffAddr#)
 257            | t == word32PrimTyCon = MKDECODER(1,W32#,indexWord32OffAddr#)
 258            | t == int64PrimTyCon  = MKDECODER(2,I64#,indexInt64OffAddr#)
 259            | t == word64PrimTyCon = MKDECODER(2,W64#,indexWord64OffAddr#)
 260            | t == addrPrimTyCon   = MKDECODER(1,I#,(\x off-> addr2Int# (indexAddrOffAddr# x off)))  --OPT Improve the presentation of addresses
 261            | t == stablePtrPrimTyCon  = (1, "<stablePtr>")
 262            | t == stableNamePrimTyCon = (1, "<stableName>")
 263            | t == statePrimTyCon      = (1, "<statethread>")
 264            | t == realWorldTyCon      = (1, "<realworld>")
 265            | t == threadIdPrimTyCon   = (1, "<ThreadId>")
 266            | t == weakPrimTyCon       = (1, "<Weak>")
 267            | t == arrayPrimTyCon      = (1,"<array>")
 268            | t == byteArrayPrimTyCon  = (1,"<bytearray>")
 269            | t == mutableArrayPrimTyCon = (1, "<mutableArray>")
 270            | t == mutableByteArrayPrimTyCon = (1, "<mutableByteArray>")
 271            | t == mutVarPrimTyCon= (1, "<mutVar>")
 272            | t == mVarPrimTyCon  = (1, "<mVar>")
 273            | t == tVarPrimTyCon  = (1, "<tVar>")
 274            | otherwise = (1, showSDoc (char '<' <> ppr t <> char '>'))
 275                  -- We cannot know the right offset in the otherwise case, so 1 is just a wild dangerous guess!
 276            -- TODO: Improve the offset handling in decode (make it machine dependant)
 277
 278 -----------------------------------
 279 -- Boilerplate Fold code for Term
 280 -----------------------------------
 281
 282 data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
 283                            , fPrim :: Type -> String -> a
 284                            , fSuspension :: ClosureType -> Maybe Type -> HValue -> Maybe Name -> a
 285                            }
 286
 287 foldTerm :: TermFold a -> Term -> a
 288 foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
 289 foldTerm tf (Prim ty    v   ) = fPrim tf ty v
 290 foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b
 291
 292 idTermFold :: TermFold Term
 293 idTermFold = TermFold {
 294               fTerm = Term,
 295               fPrim = Prim,
 296               fSuspension = Suspension
 297                       }
 298 idTermFoldM :: Monad m => TermFold (m Term)
 299 idTermFoldM = TermFold {
 300               fTerm       = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
 301               fPrim       = (return.). Prim,
 302               fSuspension = (((return.).).). Suspension
 303                        }
 304
 305 ----------------------------------
 306 -- Pretty printing of terms
 307 ----------------------------------
 308
 309 parensCond True  = parens
 310 parensCond False = id
 311 app_prec::Int
 312 app_prec = 10
 313
 314 printTerm :: Term -> SDoc
 315 printTerm Prim{value=value} = text value
 316 printTerm t@Term{} = printTerm1 0 t
 317 printTerm Suspension{bound_to=Nothing} =  char '_' -- <> ppr ct <> char '_'
 318 printTerm Suspension{mb_ty=Just ty, bound_to=Just n} =
 319   parens$ ppr n <> text "::" <> ppr ty
 320
 321 printTerm1 p Term{dc=dc, subTerms=tt}
 322 {-  | dataConIsInfix dc, (t1:t2:tt') <- tt
 323   = parens (printTerm1 True t1 <+> ppr dc <+> printTerm1 True ppr t2)
 324     <+> hsep (map (printTerm1 True) tt)
 325 -}
 326   | null tt   = ppr dc
 327   | otherwise = parensCond (p > app_prec)
 328                      (ppr dc <+> sep (map (printTerm1 (app_prec+1)) tt))
 329
 330   where fixity   = undefined
 331
 332 printTerm1 _ t = printTerm t
 333
 334 customPrintTerm :: Monad m => ((Int->Term->m SDoc)->[Term->m (Maybe SDoc)]) -> Term -> m SDoc
 335 customPrintTerm custom = let
 336 --  go :: Monad m => Int -> Term -> m SDoc
 337   go prec t@Term{subTerms=tt, dc=dc} = do
 338     mb_customDocs <- sequence$ sequence (custom go) t  -- Inner sequence is List monad
 339     case msum mb_customDocs of        -- msum is in Maybe monad
 340       Just doc -> return$ parensCond (prec>app_prec+1) doc
 341 --    | dataConIsInfix dc, (t1:t2:tt') <- tt =
 342       Nothing  -> do pprSubterms <- mapM (go (app_prec+1)) tt
 343                      return$ parensCond (prec>app_prec+1)
 344                                         (ppr dc <+> sep pprSubterms)
 345   go _ t = return$ printTerm t
 346   in go 0
 347    where fixity = undefined
 348
 349 customPrintTermBase :: Monad m => (Int->Term-> m SDoc)->[Term->m (Maybe SDoc)]
 350 customPrintTermBase showP =
 351   [
 352     test isTupleDC (liftM (parens . hcat . punctuate comma) . mapM (showP 0) . subTerms)
 353   , test (isDC consDataCon) (\Term{subTerms=[h,t]} -> doList h t)
 354   , test (isDC intDataCon)  (coerceShow$ \(a::Int)->a)
 355   , test (isDC charDataCon) (coerceShow$ \(a::Char)->a)
 356 --  , test (isDC wordDataCon) (coerceShow$ \(a::Word)->a)
 357   , test (isDC floatDataCon) (coerceShow$ \(a::Float)->a)
 358   , test (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)
 359   , test isIntegerDC (coerceShow$ \(a::Integer)->a)
 360   ]
 361      where test pred f t = if pred t then liftM Just (f t) else return Nothing
 362            isIntegerDC Term{dc=dc} =
 363               dataConName dc `elem` [ smallIntegerDataConName
 364                                     , largeIntegerDataConName]
 365            isTupleDC Term{dc=dc}   = dc `elem` snd (unzip (elems boxedTupleArr))
 366            isDC a_dc Term{dc=dc}   = a_dc == dc
 367            coerceShow f = return . text . show . f . unsafeCoerce# . val
 368            --TODO pprinting of list terms is not lazy
 369            doList h t = do
 370                let elems = h : getListTerms t
 371                    isConsLast = isSuspension (last elems) &&
 372                                 (mb_ty$ last elems) /= (termType h)
 373                init <- mapM (showP 0) (init elems)
 374                last0 <- showP 0 (last elems)
 375                let last = case length elems of
 376                             1 -> last0
 377                             _ | isConsLast -> text " | " <> last0
 378                             _ -> comma <> last0
 379                return$ brackets (hcat (punctuate comma init ++ [last]))
 380
 381                 where Just a /= Just b = not (a `coreEqType` b)
 382                       _      /=   _    = True
 383                       getListTerms Term{subTerms=[h,t]} = h : getListTerms t
 384                       getListTerms t@Term{subTerms=[]}  = []
 385                       getListTerms t@Suspension{}       = [t]
 386                       getListTerms t = pprPanic "getListTerms" (ppr t)
 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 (sigmaType 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 -- Is this defined elsewhere?
 546 -- Find all free tyvars and insert the appropiate ForAll.
 547 sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty
 548
 549 {-
 550 Example of Type Reconstruction
 551 --------------------------------
 552 Suppose we have an existential type such as
 553
 554 data Opaque = forall a. Opaque a
 555
 556 And we have a term built as:
 557
 558 t = Opaque (map Just [[1,1],[2,2]])
 559
 560 The type of t as far as the typechecker goes is t :: Opaque
 561 If we seq the head of t, we obtain:
 562
 563 t - O (_1::a)
 564
 565 seq _1 ()
 566
 567 t - O ( (_3::b) : (_4::[b]) )
 568
 569 seq _3 ()
 570
 571 t - O ( (Just (_5::c)) : (_4::[b]) )
 572
 573 At this point, we know that b = (Maybe c)
 574
 575 seq _5 ()
 576
 577 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[b]) )
 578
 579 At this point, we know that c = [d]
 580
 581 seq _6 ()
 582
 583 t - O ( (Just (1 : (_7::[d]) )) : (_4::[b]) )
 584
 585 At this point, we know that d = Integer
 586
 587 The fully reconstructed expressions, with propagation, would be:
 588
 589 t - O ( (Just (_5::c)) : (_4::[Maybe c]) )
 590 t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[Maybe [d]]) )
 591 t - O ( (Just (1 : (_7::[Integer]) )) : (_4::[Maybe [Integer]]) )
 592
 593
 594 For reference, the type of the thing inside the opaque is
 595 map Just [[1,1],[2,2]] :: [Maybe [Integer]]
 596
 597 NOTE: (Num t) contexts have been manually replaced by Integer for clarity
 598 -}
 599
 600 --------------------------------------------------------------------
 601 -- The DataConEnv is used to store the addresses of datacons loaded
 602 -- via the dynamic linker
 603 --------------------------------------------------------------------
 604
 605 type DataConEnv   = AddressEnv StgInfoTable
 606
 607 -- Note that this AddressEnv and DataConEnv I wrote trying to follow
 608 -- conventions in ghc, but probably they make not much sense.
 609
 610 newtype AddressEnv a = AE {aenv:: FiniteMap (Ptr a) Name}
 611   deriving (Outputable)
 612
 613 emptyAddressEnv = AE emptyFM
 614
 615 extendAddressEnvList  :: AddressEnv a -> [(Ptr a, Name)] -> AddressEnv a
 616 elemAddressEnv        :: Ptr a -> AddressEnv a -> Bool
 617 delFromAddressEnv     :: AddressEnv a -> Ptr a -> AddressEnv a
 618 nullAddressEnv        :: AddressEnv a -> Bool
 619 lookupAddressEnv       :: AddressEnv a -> Ptr a -> Maybe Name
 620
 621 extendAddressEnvList  (AE env) = AE . addListToFM env
 622 elemAddressEnv   ptr  (AE env) = ptr `elemFM` env
 623 delFromAddressEnv     (AE env) = AE . delFromFM env
 624 nullAddressEnv                 = isEmptyFM . aenv
 625 lookupAddressEnv      (AE env) = lookupFM env
 626
 627
 628 instance Outputable (Ptr a) where
 629   ppr = text . show