RtClosureInspect.hs 23.2 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12
-----------------------------------------------------------------------------
--
-- GHC Interactive support for inspecting arbitrary closures at runtime
--
-- Pepe Iborra (supported by Google SoC) 2006
--
-----------------------------------------------------------------------------

module RtClosureInspect(
  
     cvObtainTerm,       -- :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term

Simon Marlow's avatar
Simon Marlow committed
13
     Term(..),
14 15 16
     pprTerm, 
     cPprTerm, 
     cPprTermBase,
17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68
     termType,
     foldTerm, 
     TermFold(..), 
     idTermFold, 
     idTermFoldM,
     isFullyEvaluated, 
     isPointed,
     isFullyEvaluatedTerm,
--     unsafeDeepSeq, 
 ) where 

#include "HsVersions.h"

import ByteCodeItbls    ( StgInfoTable )
import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
import ByteCodeLink     ( HValue )
import HscTypes         ( HscEnv )

import DataCon          
import Type             
import TcRnMonad        ( TcM, initTcPrintErrors, ioToTcRn, recoverM, writeMutVar )
import TcType
import TcMType
import TcUnify
import TcGadt
import TyCon		
import Var
import Name 
import VarEnv
import OccName
import VarSet
import {-#SOURCE#-} TcRnDriver ( tcRnRecoverDataCon )

import TysPrim		
import PrelNames
import TysWiredIn

import Constants        ( wORD_SIZE )
import Outputable
import Maybes
import Panic
import FiniteMap

import GHC.Arr          ( Array(..) )
import GHC.Ptr          ( Ptr(..), castPtr )
import GHC.Exts         
import GHC.Int          ( Int32(..),  Int64(..) )
import GHC.Word         ( Word32(..), Word64(..) )

import Control.Monad
import Data.Maybe
import Data.Array.Base
69
import Data.List        ( partition, nub )
70 71
import Foreign.Storable

72 73
import IO

74 75 76 77 78 79 80 81 82 83
---------------------------------------------
-- * A representation of semi evaluated Terms
---------------------------------------------
{-
  A few examples in this representation:

  > Just 10 = Term Data.Maybe Data.Maybe.Just (Just 10) [Term Int I# (10) "10"]

  > (('a',_,_),_,('b',_,_)) = 
      Term ((Char,b,c),d,(Char,e,f)) (,,) (('a',_,_),_,('b',_,_))
84 85 86
          [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
          , Suspension
          , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112
-}

data Term = Term { ty        :: Type 
                 , dc        :: DataCon 
                 , val       :: HValue 
                 , subTerms  :: [Term] }

          | Prim { ty        :: Type
                 , value     :: String }

          | Suspension { ctype    :: ClosureType
                       , mb_ty    :: Maybe Type
                       , val      :: HValue
                       , bound_to :: Maybe Name   -- Useful for printing
                       }

isTerm Term{} = True
isTerm   _    = False
isSuspension Suspension{} = True
isSuspension      _       = False
isPrim Prim{} = True
isPrim   _    = False

termType t@(Suspension {}) = mb_ty t
termType t = Just$ ty t

mnislaih's avatar
mnislaih committed
113 114 115 116 117
isFullyEvaluatedTerm :: Term -> Bool
isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
isFullyEvaluatedTerm Suspension {}      = False
isFullyEvaluatedTerm Prim {}            = True

118
instance Outputable (Term) where
119
 ppr = head . cPprTerm cPprTermBase
120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135

-------------------------------------------------------------------------
-- Runtime Closure Datatype and functions for retrieving closure related stuff
-------------------------------------------------------------------------
data ClosureType = Constr 
                 | Fun 
                 | Thunk Int 
                 | ThunkSelector
                 | Blackhole 
                 | AP 
                 | PAP 
                 | Indirection Int 
                 | Other Int
 deriving (Show, Eq)

data Closure = Closure { tipe         :: ClosureType 
136
                       , infoPtr      :: Ptr ()
137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152
                       , infoTable    :: StgInfoTable
                       , ptrs         :: Array Int HValue
                       , nonPtrs      :: ByteArray# 
                       }

instance Outputable ClosureType where
  ppr = text . show 

#include "../includes/ClosureTypes.h"

aP_CODE = AP
pAP_CODE = PAP
#undef AP
#undef PAP

getClosureData :: a -> IO Closure
153 154 155 156 157 158
getClosureData a =
   case unpackClosure# a of 
     (# iptr, ptrs, nptrs #) -> do
           itbl <- peek (Ptr iptr)
           let tipe = readCType (BCI.tipe itbl)
               elems = BCI.ptrs itbl 
159
               ptrsList = Array 0 (fromIntegral$ elems) ptrs
160
           ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs)
161 162 163 164 165 166 167 168 169 170

readCType :: Integral a => a -> ClosureType
readCType i
 | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr
 | i >= FUN    && i <= FUN_STATIC          = Fun
 | i >= THUNK  && i < THUNK_SELECTOR       = Thunk (fromIntegral i)
 | i == THUNK_SELECTOR                     = ThunkSelector
 | i == BLACKHOLE                          = Blackhole
 | i >= IND    && i <= IND_STATIC          = Indirection (fromIntegral i)
 | fromIntegral i == aP_CODE               = AP
171
 | i == AP_STACK                           = AP
172 173 174 175 176 177 178 179 180 181 182
 | fromIntegral i == pAP_CODE              = PAP
 | otherwise                               = Other (fromIntegral i)

isConstr, isIndirection :: ClosureType -> Bool
isConstr Constr = True
isConstr    _   = False

isIndirection (Indirection _) = True
--isIndirection ThunkSelector = True
isIndirection _ = False

183 184 185 186 187
isThunk (Thunk _)     = True
isThunk ThunkSelector = True
isThunk AP            = True
isThunk _             = False

188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260
isFullyEvaluated :: a -> IO Bool
isFullyEvaluated a = do 
  closure <- getClosureData a 
  case tipe closure of
    Constr -> do are_subs_evaluated <- amapM isFullyEvaluated (ptrs closure)
                 return$ and are_subs_evaluated
    otherwise -> return False
  where amapM f = sequence . amap' f

amap' f (Array i0 i arr#) = map (\(I# i#) -> case indexArray# arr# i# of
                                   (# e #) -> f e)
                                [0 .. i - i0]

-- TODO: Fix it. Probably the otherwise case is failing, trace/debug it
{-
unsafeDeepSeq :: a -> b -> b
unsafeDeepSeq = unsafeDeepSeq1 2
 where unsafeDeepSeq1 0 a b = seq a $! b
       unsafeDeepSeq1 i a b                -- 1st case avoids infinite loops for non reducible thunks
        | not (isConstr tipe) = seq a $! unsafeDeepSeq1 (i-1) a b     
     -- | unsafePerformIO (isFullyEvaluated a) = b
        | otherwise = case unsafePerformIO (getClosureData a) of
                        closure -> foldl' (flip unsafeDeepSeq) b (ptrs closure)
        where tipe = unsafePerformIO (getClosureType a)
-}
isPointed :: Type -> Bool
isPointed t | Just (t, _) <- splitTyConApp_maybe t = not$ isUnliftedTypeKind (tyConKind t)
isPointed _ = True

#define MKDECODER(offset,cons,builder) (offset, show$ cons (builder addr 0#))

extractUnboxed  :: [Type] -> ByteArray# -> [String]
extractUnboxed tt ba = helper tt (byteArrayContents# ba)
   where helper :: [Type] -> Addr# -> [String]
         helper (t:tt) addr 
          | Just ( tycon,_) <- splitTyConApp_maybe t 
          =  let (offset, txt) = decode tycon addr
                 (I# word_offset)   = offset*wORD_SIZE
             in txt : helper tt (plusAddr# addr word_offset)
          | otherwise 
          = -- ["extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)]
            panic$ "extractUnboxed.helper: Urk. I got a " ++ showSDoc (ppr t)
         helper [] addr = []
         decode :: TyCon -> Addr# -> (Int, String)
         decode t addr                             
           | t == charPrimTyCon   = MKDECODER(1,C#,indexCharOffAddr#)
           | t == intPrimTyCon    = MKDECODER(1,I#,indexIntOffAddr#)
           | t == wordPrimTyCon   = MKDECODER(1,W#,indexWordOffAddr#)
           | t == floatPrimTyCon  = MKDECODER(1,F#,indexFloatOffAddr#)
           | t == doublePrimTyCon = MKDECODER(2,D#,indexDoubleOffAddr#)
           | t == int32PrimTyCon  = MKDECODER(1,I32#,indexInt32OffAddr#)
           | t == word32PrimTyCon = MKDECODER(1,W32#,indexWord32OffAddr#)
           | t == int64PrimTyCon  = MKDECODER(2,I64#,indexInt64OffAddr#)
           | t == word64PrimTyCon = MKDECODER(2,W64#,indexWord64OffAddr#)
           | t == addrPrimTyCon   = MKDECODER(1,I#,(\x off-> addr2Int# (indexAddrOffAddr# x off)))  --OPT Improve the presentation of addresses
           | t == stablePtrPrimTyCon  = (1, "<stablePtr>")
           | t == stableNamePrimTyCon = (1, "<stableName>")
           | t == statePrimTyCon      = (1, "<statethread>")
           | t == realWorldTyCon      = (1, "<realworld>")
           | t == threadIdPrimTyCon   = (1, "<ThreadId>")
           | t == weakPrimTyCon       = (1, "<Weak>")
           | t == arrayPrimTyCon      = (1,"<array>")
           | t == byteArrayPrimTyCon  = (1,"<bytearray>")
           | t == mutableArrayPrimTyCon = (1, "<mutableArray>")
           | t == mutableByteArrayPrimTyCon = (1, "<mutableByteArray>")
           | t == mutVarPrimTyCon= (1, "<mutVar>")
           | t == mVarPrimTyCon  = (1, "<mVar>")
           | t == tVarPrimTyCon  = (1, "<tVar>")
           | otherwise = (1, showSDoc (char '<' <> ppr t <> char '>')) 
                 -- We cannot know the right offset in the otherwise case, so 1 is just a wild dangerous guess!
           -- TODO: Improve the offset handling in decode (make it machine dependant)

-----------------------------------
mnislaih's avatar
mnislaih committed
261
-- * Traversals for Terms
262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293
-----------------------------------

data TermFold a = TermFold { fTerm :: Type -> DataCon -> HValue -> [a] -> a
                           , fPrim :: Type -> String -> a
                           , fSuspension :: ClosureType -> Maybe Type -> HValue -> Maybe Name -> a
                           }

foldTerm :: TermFold a -> Term -> a
foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)
foldTerm tf (Prim ty    v   ) = fPrim tf ty v
foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b

idTermFold :: TermFold Term
idTermFold = TermFold {
              fTerm = Term,
              fPrim = Prim,
              fSuspension = Suspension
                      }
idTermFoldM :: Monad m => TermFold (m Term)
idTermFoldM = TermFold {
              fTerm       = \ty dc v tt -> sequence tt >>= return . Term ty dc v,
              fPrim       = (return.). Prim,
              fSuspension = (((return.).).). Suspension
                       }

----------------------------------
-- Pretty printing of terms
----------------------------------

app_prec::Int
app_prec = 10

294 295
pprTerm :: Int -> Term -> SDoc
pprTerm p Term{dc=dc, subTerms=tt} 
296
{-  | dataConIsInfix dc, (t1:t2:tt') <- tt 
297 298
  = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2) 
    <+> hsep (map (pprTerm1 True) tt) 
299 300
-}
  | null tt   = ppr dc
301 302
  | otherwise = cparen (p >= app_prec) 
                       (ppr dc <+> sep (map (pprTerm app_prec) tt))
303 304 305

  where fixity   = undefined 

306 307 308 309 310 311 312 313 314
pprTerm _ t = pprTerm1 t

pprTerm1 Prim{value=value} = text value 
pprTerm1 t@Term{} = pprTerm 0 t 
pprTerm1 Suspension{bound_to=Nothing} =  char '_' -- <> ppr ct <> char '_'
pprTerm1 Suspension{mb_ty=Just ty, bound_to=Just n}
  | Just _ <- splitFunTy_maybe ty = ptext SLIT("<function>")
  | otherwise = parens$ ppr n <> text "::" <> ppr ty 

315

316 317
cPprTerm :: forall m. Monad m => ((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc
cPprTerm custom = go 0 where
318
  go prec t@Term{subTerms=tt, dc=dc} = do
319
    let mb_customDocs = map (($t) . ($prec)) (custom go) :: [m (Maybe SDoc)]    
320 321
    first_success <- firstJustM mb_customDocs
    case first_success of
322
      Just doc -> return$ cparen (prec>app_prec+1) doc
323 324
--    | dataConIsInfix dc, (t1:t2:tt') <- tt =
      Nothing  -> do pprSubterms <- mapM (go (app_prec+1)) tt
325 326 327
                     return$ cparen (prec >= app_prec) 
                                    (ppr dc <+> sep pprSubterms)
  go _ t = return$ pprTerm1 t
328 329
  firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
  firstJustM [] = return Nothing
330

331 332
cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[Int->Term->m (Maybe SDoc)]
cPprTermBase pprP =
333
  [ 
334 335 336 337 338 339 340 341 342
    ifTerm isTupleDC            (\_ -> liftM (parens . hcat . punctuate comma) 
                                 . mapM (pprP (-1)) . subTerms)
  , ifTerm (isDC consDataCon)   (\ p Term{subTerms=[h,t]} -> doList p h t)
  , ifTerm (isDC intDataCon)    (coerceShow$ \(a::Int)->a)
  , ifTerm (isDC charDataCon)   (coerceShow$ \(a::Char)->a)
--  , ifTerm (isDC wordDataCon) (coerceShow$ \(a::Word)->a)
  , ifTerm (isDC floatDataCon)  (coerceShow$ \(a::Float)->a)
  , ifTerm (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)
  , ifTerm isIntegerDC          (coerceShow$ \(a::Integer)->a)
343
  ] 
344
     where ifTerm pred f p t = if pred t then liftM Just (f p t) else return Nothing
345 346 347
           isIntegerDC Term{dc=dc} = 
              dataConName dc `elem` [ smallIntegerDataConName
                                    , largeIntegerDataConName] 
348 349 350
           isTupleDC Term{dc=dc} = dc `elem` snd (unzip (elems boxedTupleArr))
           isDC a_dc Term{dc=dc} = a_dc == dc
           coerceShow f _ = return . text . show . f . unsafeCoerce# . val
351
           --TODO pprinting of list terms is not lazy
352
           doList p h t = do
353
               let elems = h : getListTerms t
354 355 356 357 358 359
                   isConsLast = termType(last elems) /= termType h
               print_elems <- mapM (pprP 5) elems
               return$ if isConsLast
                     then cparen (p >= 5) . hsep . punctuate (space<>colon) 
                           $ print_elems
                     else brackets (hcat$ punctuate comma print_elems)
360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385

                where Just a /= Just b = not (a `coreEqType` b)
                      _      /=   _    = True
                      getListTerms Term{subTerms=[h,t]} = h : getListTerms t
                      getListTerms t@Term{subTerms=[]}  = []
                      getListTerms t@Suspension{}       = [t]
                      getListTerms t = pprPanic "getListTerms" (ppr t)

-----------------------------------
-- Type Reconstruction
-----------------------------------

-- The Type Reconstruction monad
type TR a = TcM a

runTR :: HscEnv -> TR Term -> IO Term
runTR hsc_env c = do 
  mb_term <- initTcPrintErrors hsc_env iNTERACTIVE (c >>= zonkTerm)
  case mb_term of 
    Nothing -> panic "Can't unify"
    Just term -> return term

trIO :: IO a -> TR a 
trIO = liftTcM . ioToTcRn

addConstraint :: TcType -> TcType -> TR ()
386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428
addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry unifyType 

{-
   A parallel fold over two Type values, 
 compensating for missing newtypes on both sides. 
 This is necessary because newtypes are not present 
 in runtime, but since sometimes there is evidence 
 available we do our best to reconstruct them. 
   Evidence can come from DataCon signatures or 
 from compile-time type inference.
   I am using the words congruence and rewriting 
 because what we are doing here is an approximation 
 of unification modulo a set of equations, which would 
 come from newtype definitions. These should be the 
 equality coercions seen in System Fc. Rewriting 
 is performed, taking those equations as rules, 
 before launching unification.

   It doesn't make sense to rewrite everywhere, 
 or we would end up with all newtypes. So we rewrite 
 only in presence of evidence.
   The lhs comes from the heap structure of ptrs,nptrs. 
   The rhs comes from a DataCon type signature. 
 Rewriting in the rhs is restricted to the result type.

   Note that it is very tricky to make this 'rewriting'
 work with the unification implemented by TcM, where
 substitutions are 'inlined'. The order in which 
 constraints are unified is vital for this (or I am 
 using TcM wrongly).
-}
congruenceNewtypes ::  TcType -> TcType -> TcM (TcType,TcType)
congruenceNewtypes = go True
  where 
   go rewriteRHS lhs rhs  
 -- TyVar lhs inductive case
    | Just tv <- getTyVar_maybe lhs 
    = recoverM (return (lhs,rhs)) $ do  
         Indirect ty_v <- readMetaTyVar tv
         (lhs', rhs') <- go rewriteRHS ty_v rhs
         writeMutVar (metaTvRef tv) (Indirect lhs')
         return (lhs, rhs')
 -- TyVar rhs inductive case
429
    | Just tv <- getTyVar_maybe rhs 
430
    = recoverM (return (lhs,rhs)) $ do  
431
         Indirect ty_v <- readMetaTyVar tv
432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460
         (lhs', rhs') <- go rewriteRHS lhs ty_v
         writeMutVar (metaTvRef tv) (Indirect rhs')
         return (lhs', rhs)
-- FunTy inductive case
    | Just (l1,l2) <- splitFunTy_maybe lhs
    , Just (r1,r2) <- splitFunTy_maybe rhs
    = do (l2',r2') <- go True l2 r2
         (l1',r1') <- go False l1 r1
         return (mkFunTy l1' l2', mkFunTy r1' r2')
-- TyconApp Inductive case; this is the interesting bit.
    | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
    , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs = do

      let (tycon_l',args_l') = if isNewTyCon tycon_r && not(isNewTyCon tycon_l)
                                then (tycon_r, rewrite tycon_r lhs)
                                else (tycon_l, args_l)
          (tycon_r',args_r') = if rewriteRHS && isNewTyCon tycon_l && not(isNewTyCon tycon_r)
                                then (tycon_l, rewrite tycon_l rhs)
                                else (tycon_r, args_r)
      (args_l'', args_r'') <- unzip `liftM` zipWithM (go rewriteRHS) args_l' args_r'
      return (mkTyConApp tycon_l' args_l'', mkTyConApp tycon_r' args_r'') 

    | otherwise = return (lhs,rhs)

    where rewrite newtyped_tc lame_tipe
           | (tvs, tipe) <- newTyConRep newtyped_tc 
           = case tcUnifyTys (const BindMe) [tipe] [lame_tipe] of
               Just subst -> substTys subst (map mkTyVarTy tvs)
               otherwise  -> panic "congruenceNewtypes: Can't unify a newtype"
461 462 463 464 465 466

newVar :: Kind -> TR TcTyVar
newVar = liftTcM . newFlexiTyVar

liftTcM = id

467 468 469 470 471 472
-- | Returns the instantiated type scheme ty', and the substitution sigma 
--   such that sigma(ty') = ty 
instScheme :: Type -> TR (TcType, TvSubst)
instScheme ty | (tvs, rho) <- tcSplitForAllTys ty = liftTcM$ do
   (tvs',theta,ty') <- tcInstType (mapM tcInstTyVar) ty
   return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
473 474

cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
475
cvObtainTerm hsc_env force mb_ty hval = runTR hsc_env $ do
476 477 478 479 480
   tv <- liftM mkTyVarTy (newVar argTypeKind)
   case mb_ty of
     Nothing -> go tv tv hval
     Just ty | isMonomorphic ty -> go ty ty hval
     Just ty -> do 
481
              (ty',rev_subst) <- instScheme (sigmaType ty)
482 483 484 485 486 487 488
              addConstraint tv ty'
              term <- go tv tv hval
              --restore original Tyvars
              return$ flip foldTerm term idTermFold {
                fTerm = \ty dc hval tt -> Term (substTy rev_subst ty) dc hval tt,
                fSuspension = \ct mb_ty hval n -> 
                          Suspension ct (substTy rev_subst `fmap` mb_ty) hval n}
489
    where 
490 491 492
  go tv ty a = do 
    let monomorphic = not(isTyVarTy tv)   -- This is a convention. The ancestor tests for
                                         -- monomorphism and passes a type instead of a tv
493 494
    clos <- trIO $ getClosureData a
    case tipe clos of
495
-- Thunks we may want to force
496
      t | isThunk t && force -> seq a $ go tv ty a
497
-- We always follow indirections 
498
      Indirection _ -> go tv ty $! (ptrs clos ! 0)
499 500
 -- The interesting case
      Constr -> do
501
        m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
502 503 504 505
        case m_dc of
          Nothing -> panic "Can't find the DataCon for a term"
          Just dc -> do 
            let extra_args = length(dataConRepArgTys dc) - length(dataConOrigArgTys dc)
506
                subTtypes  = matchSubTypes dc ty
507
                (subTtypesP, subTtypesNP) = partition isPointed subTtypes
508 509 510 511 512 513 514
            subTermTvs <- sequence
                 [ if isMonomorphic t then return t else (mkTyVarTy `fmap` newVar k)
                   | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
            -- It is vital for newtype reconstruction that the unification step is done
            --     right here, _before_ the subterms are RTTI reconstructed.
            when (not monomorphic) $ do
                  let myType = mkFunTys (reOrderTerms subTermTvs subTtypesNP subTtypes) tv
515
                  instScheme(dataConRepType dc) >>= addConstraint myType . fst
516 517 518
            subTermsP <- sequence $ drop extra_args -- all extra arguments are pointed
                  [ appArr (go tv t) (ptrs clos) i
                   | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
519 520
            let unboxeds   = extractUnboxed subTtypesNP (nonPtrs clos)
                subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)      
521
                subTerms   = reOrderTerms subTermsP subTermsNP (drop extra_args subTtypes)
522
            return (Term tv dc a subTerms)
523
-- The otherwise case: can be a Thunk,AP,PAP,etc.
mnislaih's avatar
wibbles  
mnislaih committed
524
      otherwise -> 
525
         return (Suspension (tipe clos) (Just tv) a Nothing)
526 527 528

-- Access the array of pointers and recurse down. Needs to be done with
-- care of no introducing a thunk! or go will fail to do its job 
529
  appArr f arr (I# i#) = case arr of 
530
                 (Array _ _ ptrs#) -> case indexArray# ptrs# i# of 
531 532 533 534 535 536 537 538
                       (# e #) -> f e

  matchSubTypes dc ty
    | Just (_,ty_args) <- splitTyConApp_maybe (repType ty) 
    , null (dataConExTyVars dc)  --TODO Handle the case of extra existential tyvars
    = dataConInstArgTys dc ty_args

    | otherwise = dataConRepArgTys dc
539 540 541 542 543

-- This is used to put together pointed and nonpointed subterms in the 
--  correct order.
  reOrderTerms _ _ [] = []
  reOrderTerms pointed unpointed (ty:tys) 
mnislaih's avatar
mnislaih committed
544 545 546 547 548 549
   | isPointed ty = ASSERT2(not(null pointed)
                           , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed))
                    head pointed : reOrderTerms (tail pointed) unpointed tys
   | otherwise    = ASSERT2(not(null unpointed)
                           , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed))
                    head unpointed : reOrderTerms pointed (tail unpointed) tys
550

551 552
isMonomorphic ty | isForAllTy ty = False
isMonomorphic ty = (isEmptyVarSet . tyVarsOfType) ty
553 554 555 556 557 558 559 560 561

zonkTerm :: Term -> TcM Term
zonkTerm = foldTerm idTermFoldM {
              fTerm = \ty dc v tt -> sequence tt      >>= \tt ->
                                     zonkTcType ty    >>= \ty' ->
                                     return (Term ty' dc v tt)
             ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty ->
                                          return (Suspension ct ty v b)}  

mnislaih's avatar
mnislaih committed
562 563

-- Is this defined elsewhere?
564
-- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
mnislaih's avatar
mnislaih committed
565 566
sigmaType ty = mkForAllTys (varSetElems$ tyVarsOfType (dropForAlls ty)) ty

567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616
{-
Example of Type Reconstruction
--------------------------------
Suppose we have an existential type such as

data Opaque = forall a. Opaque a

And we have a term built as:

t = Opaque (map Just [[1,1],[2,2]])

The type of t as far as the typechecker goes is t :: Opaque
If we seq the head of t, we obtain:

t - O (_1::a) 

seq _1 ()

t - O ( (_3::b) : (_4::[b]) ) 

seq _3 ()

t - O ( (Just (_5::c)) : (_4::[b]) ) 

At this point, we know that b = (Maybe c)

seq _5 ()

t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[b]) )

At this point, we know that c = [d]

seq _6 ()

t - O ( (Just (1 : (_7::[d]) )) : (_4::[b]) )

At this point, we know that d = Integer

The fully reconstructed expressions, with propagation, would be:

t - O ( (Just (_5::c)) : (_4::[Maybe c]) ) 
t - O ( (Just ((_6::d) : (_7::[d]) )) : (_4::[Maybe [d]]) )
t - O ( (Just (1 : (_7::[Integer]) )) : (_4::[Maybe [Integer]]) )


For reference, the type of the thing inside the opaque is 
map Just [[1,1],[2,2]] :: [Maybe [Integer]]

NOTE: (Num t) contexts have been manually replaced by Integer for clarity
-}