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

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

Simon Marlow's avatar
Simon Marlow committed
13
     Term(..),
mnislaih's avatar
mnislaih committed
14
15
16
     isTerm,
     isSuspension,
     isPrim,
17
18
19
     pprTerm, 
     cPprTerm, 
     cPprTermBase,
20
21
22
23
24
25
26
27
     termType,
     foldTerm, 
     TermFold(..), 
     idTermFold, 
     idTermFoldM,
     isFullyEvaluated, 
     isPointed,
     isFullyEvaluatedTerm,
28
     mapTermType,
29
     termTyVars,
30
--     unsafeDeepSeq, 
31
     cvReconstructType,
mnislaih's avatar
mnislaih committed
32
     computeRTTIsubst, 
mnislaih's avatar
mnislaih committed
33
34
35
36
37
38
     sigmaType,
     Closure(..),
     getClosureData,
     ClosureType(..),
     isConstr,
     isIndirection
39
40
41
42
43
44
45
 ) where 

#include "HsVersions.h"

import ByteCodeItbls    ( StgInfoTable )
import qualified ByteCodeItbls as BCI( StgInfoTable(..) )
import HscTypes         ( HscEnv )
46
import Linker
47
48
49

import DataCon          
import Type             
mnislaih's avatar
mnislaih committed
50
import TcRnMonad        ( TcM, initTc, ioToTcRn, 
51
                          tryTcErrs)
52
53
54
55
import TcType
import TcMType
import TcUnify
import TcGadt
56
import TcEnv
57
import DriverPhases
58
59
60
import TyCon		
import Name 
import VarEnv
61
import Util
62
63
64
65
66
67
import VarSet

import TysPrim		
import PrelNames
import TysWiredIn

68
import Constants
69
70
71
72
73
import Outputable
import Maybes
import Panic

import GHC.Arr          ( Array(..) )
74
import GHC.Exts
75
76
77
78

import Control.Monad
import Data.Maybe
import Data.Array.Base
79
import Data.List        ( partition )
80
import Foreign
81
import System.IO.Unsafe
82

83
84
85
86
87
88
89
90
91
92
---------------------------------------------
-- * 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',_,_))
93
94
95
          [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Suspension, Suspension]
          , Suspension
          , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Suspension, Suspension]]
96
97
98
-}

data Term = Term { ty        :: Type 
99
100
101
102
103
                 , dc        :: Either String DataCon
                               -- The heap datacon. If ty is a newtype,
                               -- this is NOT the newtype datacon.
                               -- Empty if the datacon aint exported by the .hi
                               -- (private constructors in -O0 libraries)
104
105
106
107
                 , val       :: HValue 
                 , subTerms  :: [Term] }

          | Prim { ty        :: Type
108
                 , value     :: [Word] }
109
110
111
112
113
114
115

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

116
isTerm, isSuspension, isPrim :: Term -> Bool
117
118
119
120
121
122
123
isTerm Term{} = True
isTerm   _    = False
isSuspension Suspension{} = True
isSuspension      _       = False
isPrim Prim{} = True
isPrim   _    = False

124
termType :: Term -> Maybe Type
125
126
127
termType t@(Suspension {}) = mb_ty t
termType t = Just$ ty t

mnislaih's avatar
mnislaih committed
128
129
130
131
132
isFullyEvaluatedTerm :: Term -> Bool
isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
isFullyEvaluatedTerm Suspension {}      = False
isFullyEvaluatedTerm Prim {}            = True

133
instance Outputable (Term) where
134
 ppr = head . cPprTerm cPprTermBase
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150

-------------------------------------------------------------------------
-- 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 
151
                       , infoPtr      :: Ptr ()
152
153
                       , infoTable    :: StgInfoTable
                       , ptrs         :: Array Int HValue
154
                       , nonPtrs      :: [Word]
155
156
157
158
159
160
161
162
163
164
165
166
167
                       }

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
168
169
170
171
172
getClosureData a =
   case unpackClosure# a of 
     (# iptr, ptrs, nptrs #) -> do
           itbl <- peek (Ptr iptr)
           let tipe = readCType (BCI.tipe itbl)
173
174
               elems = fromIntegral (BCI.ptrs itbl)
               ptrsList = Array 0 (elems - 1) elems ptrs
175
176
               nptrs_data = [W# (indexWordArray# nptrs i)
                              | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
177
           ASSERT(fromIntegral elems >= 0) return ()
178
179
           ptrsList `seq` 
            return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
180
181
182
183
184
185
186
187
188
189

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
190
 | i == AP_STACK                           = AP
191
192
193
 | fromIntegral i == pAP_CODE              = PAP
 | otherwise                               = Other (fromIntegral i)

194
isConstr, isIndirection, isThunk :: ClosureType -> Bool
195
196
197
198
199
200
201
isConstr Constr = True
isConstr    _   = False

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

202
203
204
205
206
isThunk (Thunk _)     = True
isThunk ThunkSelector = True
isThunk AP            = True
isThunk _             = False

207
208
209
210
211
212
213
214
215
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

216
217
218
amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
    where g (I# i#) = case indexArray# arr# i# of
                          (# e #) -> f e
219
220
221
222
223
224

-- 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
225
       unsafeDeepSeq1 i a b   -- 1st case avoids infinite loops for non reducible thunks
226
227
228
229
230
231
232
        | 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
233
234
isPointed t | Just (t, _) <- splitTyConApp_maybe t 
            = not$ isUnliftedTypeKind (tyConKind t)
235
236
isPointed _ = True

237
238
239
240
241
242
243
244
extractUnboxed  :: [Type] -> Closure -> [[Word]]
extractUnboxed tt clos = go tt (nonPtrs clos)
   where sizeofType t
           | Just (tycon,_) <- splitTyConApp_maybe t
           = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
           | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
         go [] _ = []
         go (t:tt) xx 
245
           | (x, rest) <- splitAt ((sizeofType t + wORD_SIZE - 1) `div` wORD_SIZE) xx 
246
247
248
           = x : go tt rest

sizeofTyCon = sizeofPrimRep . tyConPrimRep
249
250

-----------------------------------
mnislaih's avatar
mnislaih committed
251
-- * Traversals for Terms
252
253
-----------------------------------

254
data TermFold a = TermFold { fTerm :: Type -> Either String DataCon -> HValue -> [a] -> a
255
                           , fPrim :: Type -> [Word] -> a
256
257
                           , fSuspension :: ClosureType -> Maybe Type -> HValue
                                           -> Maybe Name -> a
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
                           }

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
                       }

278
mapTermType :: (Type -> Type) -> Term -> Term
279
280
281
282
283
mapTermType f = foldTerm idTermFold {
          fTerm       = \ty dc hval tt -> Term (f ty) dc hval tt,
          fSuspension = \ct mb_ty hval n ->
                          Suspension ct (fmap f mb_ty) hval n }

284
termTyVars :: Term -> TyVarSet
285
286
287
288
289
290
291
termTyVars = foldTerm TermFold {
            fTerm       = \ty _ _ tt   -> 
                          tyVarsOfType ty `plusVarEnv` concatVarEnv tt,
            fSuspension = \_ mb_ty _ _ -> 
                          maybe emptyVarEnv tyVarsOfType mb_ty,
            fPrim       = \ _ _ -> emptyVarEnv }
    where concatVarEnv = foldr plusVarEnv emptyVarEnv
292
293
294
295
----------------------------------
-- Pretty printing of terms
----------------------------------

296
app_prec,cons_prec ::Int
297
app_prec = 10
298
cons_prec = 5 -- TODO Extract this info from GHC itself
299

300
301
302
pprTerm y p t | Just doc <- pprTermM y p t = doc

pprTermM :: Monad m => (Int -> Term -> m SDoc) -> Int -> Term -> m SDoc
303
304
305
306
307
pprTermM y p t@Term{dc=Left dc_tag, subTerms=tt, ty=ty} = do
  tt_docs <- mapM (y app_prec) tt
  return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> sep tt_docs)
  
pprTermM y p t@Term{dc=Right dc, subTerms=tt, ty=ty} 
308
{-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity
309
310
  = parens (pprTerm1 True t1 <+> ppr dc <+> pprTerm1 True ppr t2) 
    <+> hsep (map (pprTerm1 True) tt) 
311
-} -- TODO Printing infix constructors properly
312
313
314
315
316
317
318
319
320
321
322
  | null tt   = return$ ppr dc
  | Just (tc,_) <- splitNewTyConApp_maybe ty
  , isNewTyCon tc
  , Just new_dc <- maybeTyConSingleCon tc = do 
         real_value <- y 10 t{ty=repType ty}
         return$ cparen (p >= app_prec) (ppr new_dc <+> real_value)
  | otherwise = do
         tt_docs <- mapM (y app_prec) tt
         return$ cparen (p >= app_prec) (ppr dc <+> sep tt_docs)

pprTermM y _ t = pprTermM1 y t
323
324
pprTermM1 _ Prim{value=words, ty=ty} = 
    return$ text$ repPrim (tyConAppTyCon ty) words
325
326
327
328
329
330
331
332
pprTermM1 y t@Term{} = panic "pprTermM1 - unreachable"
pprTermM1 _ Suspension{bound_to=Nothing} = return$ char '_'
pprTermM1 _ Suspension{mb_ty=Just ty, bound_to=Just n}
  | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("<function>")
  | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty 

-- Takes a list of custom printers with a explicit recursion knot and a term, 
-- and returns the output of the first succesful printer, or the default printer
333
334
cPprTerm :: forall m. Monad m => 
           ((Int->Term->m SDoc)->[Int->Term->m (Maybe SDoc)]) -> Term -> m SDoc
335
cPprTerm custom = go 0 where
336
  go prec t@Term{} = do
337
338
339
340
341
    let default_ prec t = Just `liftM` pprTermM go prec t
        mb_customDocs = [pp prec t | pp <- custom go ++ [default_]]
    Just doc <- firstJustM mb_customDocs
    return$ cparen (prec>app_prec+1) doc
  go _ t = pprTermM1 go t
342
343
  firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just)
  firstJustM [] = return Nothing
344

345
-- Default set of custom printers. Note that the recursion knot is explicit
346
cPprTermBase :: Monad m => (Int->Term-> m SDoc)->[Int->Term->m (Maybe SDoc)]
347
cPprTermBase y =
348
  [ 
349
350
351
352
353
354
355
356
357
358
    ifTerm isTupleTy             (\_ -> liftM (parens . hcat . punctuate comma) 
                                 . mapM (y (-1)) . subTerms)
  , ifTerm (\t -> isTyCon listTyCon t && subTerms t `lengthIs` 2)
                                 (\ p Term{subTerms=[h,t]} -> doList p h t)
  , ifTerm (isTyCon intTyCon)    (coerceShow$ \(a::Int)->a)
  , ifTerm (isTyCon charTyCon)   (coerceShow$ \(a::Char)->a)
--  , ifTerm (isTyCon wordTyCon) (coerceShow$ \(a::Word)->a)
  , ifTerm (isTyCon floatTyCon)  (coerceShow$ \(a::Float)->a)
  , ifTerm (isTyCon doubleTyCon) (coerceShow$ \(a::Double)->a)
  , ifTerm isIntegerTy           (coerceShow$ \(a::Integer)->a)
359
  ] 
360
361
362
363
364
365
366
367
368
369
370
     where ifTerm pred f p t@Term{} | pred t = liftM Just (f p t) 
           ifTerm _    _ _ _                 = return Nothing
           isIntegerTy Term{ty=ty} = fromMaybe False $ do
             (tc,_) <- splitTyConApp_maybe ty 
             return (tyConName tc == integerTyConName)
           isTupleTy Term{ty=ty} = fromMaybe False $ do 
             (tc,_) <- splitTyConApp_maybe ty 
             return (tc `elem` (fst.unzip.elems) boxedTupleArr)
           isTyCon a_tc Term{ty=ty} = fromMaybe False $ do 
             (tc,_) <- splitTyConApp_maybe ty
             return (a_tc == tc)
371
           coerceShow f _ = return . text . show . f . unsafeCoerce# . val
372
           --TODO pprinting of list terms is not lazy
373
           doList p h t = do
374
               let elems = h : getListTerms t
375
                   isConsLast = termType(last elems) /= termType h
376
               print_elems <- mapM (y cons_prec) elems
377
               return$ if isConsLast
378
                     then cparen (p >= cons_prec) . hsep . punctuate (space<>colon) 
379
380
                           $ print_elems
                     else brackets (hcat$ punctuate comma print_elems)
381
382
383
384
385
386
387
388

                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)

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
repPrim :: TyCon -> [Word] -> String
repPrim t = rep where 
   rep x
    | t == charPrimTyCon   = show (build x :: Char)
    | t == intPrimTyCon    = show (build x :: Int)
    | t == wordPrimTyCon   = show (build x :: Word)
    | t == floatPrimTyCon  = show (build x :: Float)
    | t == doublePrimTyCon = show (build x :: Double)
    | t == int32PrimTyCon  = show (build x :: Int32)
    | t == word32PrimTyCon = show (build x :: Word32)
    | t == int64PrimTyCon  = show (build x :: Int64)
    | t == word64PrimTyCon = show (build x :: Word64)
    | t == addrPrimTyCon   = show (nullPtr `plusPtr` build x)
    | t == stablePtrPrimTyCon  = "<stablePtr>"
    | t == stableNamePrimTyCon = "<stableName>"
    | t == statePrimTyCon      = "<statethread>"
    | t == realWorldTyCon      = "<realworld>"
    | t == threadIdPrimTyCon   = "<ThreadId>"
    | t == weakPrimTyCon       = "<Weak>"
    | t == arrayPrimTyCon      = "<array>"
    | t == byteArrayPrimTyCon  = "<bytearray>"
    | t == mutableArrayPrimTyCon = "<mutableArray>"
    | t == mutableByteArrayPrimTyCon = "<mutableByteArray>"
    | t == mutVarPrimTyCon= "<mutVar>"
    | t == mVarPrimTyCon  = "<mVar>"
    | t == tVarPrimTyCon  = "<tVar>"
    | otherwise = showSDoc (char '<' <> ppr t <> char '>')
    where build ww = unsafePerformIO $ withArray ww (peek . castPtr) 
418
419
--   This ^^^ relies on the representation of Haskell heap values being 
--   the same as in a C array. 
mnislaih's avatar
mnislaih committed
420

421
422
423
-----------------------------------
-- Type Reconstruction
-----------------------------------
mnislaih's avatar
mnislaih committed
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
{-
Type Reconstruction is type inference done on heap closures.
The algorithm walks the heap generating a set of equations, which
are solved with syntactic unification.
A type reconstruction equation looks like:

  <datacon reptype>  =  <actual heap contents> 

The full equation set is generated by traversing all the subterms, starting
from a given term.

The only difficult part is that newtypes are only found in the lhs of equations.
Right hand sides are missing them. We can either (a) drop them from the lhs, or 
(b) reconstruct them in the rhs when possible. 

The function congruenceNewtypes takes a shot at (b)
-}
441
442
443
444

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

445
runTR :: HscEnv -> TR a -> IO a
446
runTR hsc_env c = do 
447
  mb_term <- runTR_maybe hsc_env c
448
449
  case mb_term of 
    Nothing -> panic "Can't unify"
450
451
452
453
    Just x  -> return x

runTR_maybe :: HscEnv -> TR a -> IO (Maybe a)
runTR_maybe hsc_env = fmap snd . initTc hsc_env HsSrcFile False iNTERACTIVE
454
455
456
457

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

458
liftTcM :: TcM a -> TR a
mnislaih's avatar
mnislaih committed
459
liftTcM = id
460

461
462
newVar :: Kind -> TR TcType
newVar = liftTcM . fmap mkTyVarTy . newFlexiTyVar
463

464
465
466
467
468
469
-- | 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))
470

471
472
473
474
475
-- Adds a constraint of the form t1 == t2
-- t1 is expected to come from walking the heap
-- t2 is expected to come from a datacon signature
-- Before unification, congruenceNewtypes needs to
-- do its magic.
mnislaih's avatar
mnislaih committed
476
477
addConstraint :: TcType -> TcType -> TR ()
addConstraint t1 t2  = congruenceNewtypes t1 t2 >>= uncurry unifyType 
478
479
		       >> return () -- TOMDO: what about the coercion?
				    -- we should consider family instances 
mnislaih's avatar
mnislaih committed
480
481

-- Type & Term reconstruction 
482
483
cvObtainTerm :: HscEnv -> Int -> Bool -> Maybe Type -> HValue -> IO Term
cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do
484
   tv <- newVar argTypeKind
485
   case mb_ty of
486
487
     Nothing -> go bound tv tv hval >>= zonkTerm
     Just ty | isMonomorphic ty -> go bound ty ty hval >>= zonkTerm
488
     Just ty -> do 
489
              (ty',rev_subst) <- instScheme (sigmaType ty)
490
              addConstraint tv ty'
491
              term <- go bound tv tv hval >>= zonkTerm
492
              --restore original Tyvars
493
              return$ mapTermType (substTy rev_subst) term
494
    where 
495
496
497
498
499
  go bound _ _ _ | seq bound False = undefined
  go 0 tv ty a = do
    clos <- trIO $ getClosureData a
    return (Suspension (tipe clos) (Just tv) a Nothing)
  go bound tv ty a = do 
500
501
502
    let monomorphic = not(isTyVarTy tv)   
    -- This ^^^ is a convention. The ancestor tests for
    -- monomorphism and passes a type instead of a tv
503
504
    clos <- trIO $ getClosureData a
    case tipe clos of
505
-- Thunks we may want to force
Simon Marlow's avatar
Simon Marlow committed
506
507
508
-- NB. this won't attempt to force a BLACKHOLE.  Even with :force, we never
-- force blackholes, because it would almost certainly result in deadlock,
-- and showing the '_' is more useful.
509
      t | isThunk t && force -> seq a $ go (pred bound) tv ty a
510
-- We always follow indirections 
511
      Indirection _ -> go (pred bound) tv ty $! (ptrs clos ! 0)
512
513
 -- The interesting case
      Constr -> do
514
515
516
517
518
519
520
521
522
523
524
        Right dcname <- dataConInfoPtrToName (infoPtr clos)
        (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
        case mb_dc of
          Nothing -> do -- This can happen for private constructors compiled -O0
                        -- where the .hi descriptor does not export them
                        -- In such case, we return a best approximation:
                        --  ignore the unpointed args, and recover the pointeds
                        -- This preserves laziness, and should be safe.
                       let tag = showSDoc (ppr dcname)
                       vars     <- replicateM (length$ elems$ ptrs clos) 
                                              (newVar (liftedTypeKind))
525
                       subTerms <- sequence [appArr (go (pred bound) tv tv) (ptrs clos) i 
526
527
                                              | (i, tv) <- zip [0..] vars]
                       return (Term tv (Left ('<' : tag ++ ">")) a subTerms)
528
          Just dc -> do 
529
530
            let extra_args = length(dataConRepArgTys dc) - 
                             length(dataConOrigArgTys dc)
531
                subTtypes  = matchSubTypes dc ty
532
                (subTtypesP, subTtypesNP) = partition isPointed subTtypes
533
            subTermTvs <- sequence
534
                 [ if isMonomorphic t then return t 
535
                                      else (newVar k)
536
                   | (t,k) <- zip subTtypesP (map typeKind subTtypesP)]
537
538
            -- It is vital for newtype reconstruction that the unification step
            --  is done right here, _before_ the subterms are RTTI reconstructed
539
            when (not monomorphic) $ do
540
541
542
543
544
545
546
547
                  let myType = mkFunTys (reOrderTerms subTermTvs 
                                                      subTtypesNP 
                                                      subTtypes) 
                                        tv
                  (signatureType,_) <- instScheme(dataConRepType dc) 
                  addConstraint myType signatureType
            subTermsP <- sequence $ drop extra_args 
                                 -- ^^^  all extra arguments are pointed
548
                  [ appArr (go (pred bound) tv t) (ptrs clos) i
549
                   | (i,tv,t) <- zip3 [0..] subTermTvs subTtypesP]
550
            let unboxeds   = extractUnboxed subTtypesNP clos
551
                subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)      
552
553
                subTerms   = reOrderTerms subTermsP subTermsNP 
                                (drop extra_args subTtypes)
554
            return (Term tv (Right dc) a subTerms)
555
-- The otherwise case: can be a Thunk,AP,PAP,etc.
556
557
      tipe_clos -> 
         return (Suspension tipe_clos (Just tv) a Nothing)
558

559
--  matchSubTypes dc ty | pprTrace "matchSubtypes" (ppr dc <+> ppr ty) False = undefined
560
561
  matchSubTypes dc ty
    | Just (_,ty_args) <- splitTyConApp_maybe (repType ty) 
562
--     assumption:             ^^^ looks through newtypes 
563
    , isVanillaDataCon dc  --TODO non-vanilla case
564
565
    = dataConInstArgTys dc ty_args
    | otherwise = dataConRepArgTys dc
566
567
568
569
570

-- 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
571
   | isPointed ty = ASSERT2(not(null pointed)
572
573
                            , ptext SLIT("reOrderTerms") $$ 
                                        (ppr pointed $$ ppr unpointed))
mnislaih's avatar
mnislaih committed
574
575
                    head pointed : reOrderTerms (tail pointed) unpointed tys
   | otherwise    = ASSERT2(not(null unpointed)
576
577
                           , ptext SLIT("reOrderTerms") $$ 
                                       (ppr pointed $$ ppr unpointed))
mnislaih's avatar
mnislaih committed
578
                    head unpointed : reOrderTerms pointed (tail unpointed) tys
579

mnislaih's avatar
mnislaih committed
580

581

582
-- Fast, breadth-first Type reconstruction
583
max_depth = 10 :: Int
584
585
586
cvReconstructType :: HscEnv -> Bool -> Maybe Type -> HValue -> IO (Maybe Type)
cvReconstructType hsc_env force mb_ty hval = runTR_maybe hsc_env $ do
   tv <- newVar argTypeKind
587
   case mb_ty of
588
589
590
591
     Nothing -> do search (isMonomorphic `fmap` zonkTcType tv)
                          (uncurry go)  
                          [(tv, hval)]  
                          max_depth
592
                   zonkTcType tv  -- TODO untested!
593
594
     Just ty | isMonomorphic ty -> return ty
     Just ty -> do 
595
              (ty',rev_subst) <- instScheme (sigmaType ty) 
596
              addConstraint tv ty'
597
              search (isMonomorphic `fmap` zonkTcType tv) 
mnislaih's avatar
mnislaih committed
598
                     (\(ty,a) -> go ty a) 
599
                     [(tv, hval)]
600
                     max_depth
601
602
603
              substTy rev_subst `fmap` zonkTcType tv
    where 
--  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()
604
605
606
  search stop expand [] depth  = return ()
  search stop expand x 0 = fail$ "Failed to reconstruct a type after " ++
                                show max_depth ++ " steps"
mnislaih's avatar
mnislaih committed
607
  search stop expand (x:xx) d  = unlessM stop $ do 
608
    new <- expand x 
mnislaih's avatar
mnislaih committed
609
    search stop expand (xx ++ new) $! (pred d)
610

611
   -- returns unification tasks,since we are going to want a breadth-first search
612
613
614
615
616
617
  go :: Type -> HValue -> TR [(Type, HValue)]
  go tv a = do 
    clos <- trIO $ getClosureData a
    case tipe clos of
      Indirection _ -> go tv $! (ptrs clos ! 0)
      Constr -> do
mnislaih's avatar
mnislaih committed
618
619
620
621
622
        Right dcname <- dataConInfoPtrToName (infoPtr clos)
        (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
        case mb_dc of
          Nothing-> do 
                     --  TODO: Check this case
623
624
625
626
627
            vars     <- replicateM (length$ elems$ ptrs clos) 
                                   (newVar (liftedTypeKind))
            subTerms <- sequence [ appArr (go tv) (ptrs clos) i 
                                   | (i, tv) <- zip [0..] vars]    
            forM [0..length (elems $ ptrs clos)] $ \i -> do
mnislaih's avatar
mnislaih committed
628
                        tv <- newVar liftedTypeKind 
629
630
                        return$ appArr (\e->(tv,e)) (ptrs clos) i

mnislaih's avatar
mnislaih committed
631
          Just dc -> do 
632
633
            let extra_args = length(dataConRepArgTys dc) - 
                             length(dataConOrigArgTys dc)
634
            subTtypes <- mapMif (not . isMonomorphic)
635
                                (\t -> newVar (typeKind t))
636
                                (dataConRepArgTys dc)
637
638
            -- It is vital for newtype reconstruction that the unification step
            -- is done right here, _before_ the subterms are RTTI reconstructed
mnislaih's avatar
wibble    
mnislaih committed
639
640
            let myType         = mkFunTys subTtypes tv
            (signatureType,_) <- instScheme(dataConRepType dc) 
641
            addConstraint myType signatureType
642
643
            return $ [ appArr (\e->(t,e)) (ptrs clos) i
                       | (i,t) <- drop extra_args $ zip [0..] subTtypes]
644
645
      otherwise -> return []

mnislaih's avatar
mnislaih committed
646
647
648
649
650
651
652
653
654
655
656
657
658
     -- This helper computes the difference between a base type t and the 
     -- improved rtti_t computed by RTTI
     -- The main difference between RTTI types and their normal counterparts
     --  is that the former are _not_ polymorphic, thus polymorphism must
     --  be stripped. Syntactically, forall's must be stripped
computeRTTIsubst ty rtti_ty = 
     -- In addition, we strip newtypes too, since the reconstructed type might
     --   not have recovered them all
           tcUnifyTys (const BindMe) 
                      [repType' $ dropForAlls$ ty]
                      [repType' $ rtti_ty]  
-- TODO stripping newtypes shouldn't be necessary, test

659

mnislaih's avatar
mnislaih committed
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
-- Dealing with newtypes
{-
   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)
691
congruenceNewtypes lhs rhs 
mnislaih's avatar
mnislaih committed
692
693
 -- TyVar lhs inductive case
    | Just tv <- getTyVar_maybe lhs 
694
    = recoverTc (return (lhs,rhs)) $ do  
mnislaih's avatar
mnislaih committed
695
         Indirect ty_v <- readMetaTyVar tv
696
697
         (lhs1, rhs1) <- congruenceNewtypes ty_v rhs
         return (lhs, rhs1)
mnislaih's avatar
mnislaih committed
698
699
700
-- FunTy inductive case
    | Just (l1,l2) <- splitFunTy_maybe lhs
    , Just (r1,r2) <- splitFunTy_maybe rhs
701
702
    = do (l2',r2') <- congruenceNewtypes l2 r2
         (l1',r1') <- congruenceNewtypes l1 r1
mnislaih's avatar
mnislaih committed
703
704
705
         return (mkFunTy l1' l2', mkFunTy r1' r2')
-- TyconApp Inductive case; this is the interesting bit.
    | Just (tycon_l, args_l) <- splitNewTyConApp_maybe lhs
706
707
708
    , Just (tycon_r, args_r) <- splitNewTyConApp_maybe rhs 
    , tycon_l /= tycon_r 
    = return (lhs, upgrade tycon_l rhs)
mnislaih's avatar
mnislaih committed
709
710
711

    | otherwise = return (lhs,rhs)

712
713
714
715
716
717
718
    where upgrade :: TyCon -> Type -> Type
          upgrade new_tycon ty
            | not (isNewTyCon new_tycon) = ty 
            | ty' <- mkTyConApp new_tycon (map mkTyVarTy $ tyConTyVars new_tycon)
            , Just subst <- tcUnifyTys (const BindMe) [ty] [repType ty']
            = substTy subst ty'
        -- assumes that reptype doesn't touch tyconApp args ^^^
mnislaih's avatar
mnislaih committed
719
720


721
--------------------------------------------------------------------------------
722
723
724
725
726
727
728
729
-- Semantically different to recoverM in TcRnMonad 
-- recoverM retains the errors in the first action,
--  whereas recoverTc here does not
recoverTc recover thing = do 
  (_,mb_res) <- tryTcErrs thing
  case mb_res of 
    Nothing  -> recover
    Just res -> return res
mnislaih's avatar
mnislaih committed
730

731
732
733
734
735
736
737
738
739
isMonomorphic ty | (tvs, ty') <- splitForAllTys ty
                 = null tvs && (isEmptyVarSet . tyVarsOfType) ty'

mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
mapMif pred f xx = sequence $ mapMif_ pred f xx
mapMif_ pred f []     = []
mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx

unlessM condM acc = condM >>= \c -> unless c acc
740

mnislaih's avatar
mnislaih committed
741
-- Strict application of f at index i
742
743
744
745
appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
 = ASSERT (i < length(elems a))
   case indexArray# ptrs# i# of
       (# e #) -> f e
mnislaih's avatar
mnislaih committed
746

747
748
749
750
751
752
753
754
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
755
756

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

760