RtClosureInspect.hs 22.7 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
-----------------------------------------------------------------------------
--
-- 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

     ClosureType(..), 
mnislaih's avatar
mnislaih committed
14
     getClosureData,     -- :: a -> IO Closure
15
     Closure ( tipe, infoPtr, ptrs, nonPtrs ), 
mnislaih's avatar
mnislaih committed
16
17
     isConstr,           -- :: ClosureType -> Bool
     isIndirection,      -- :: ClosureType -> Bool
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
69
70
71
72
73
74
75
76
77

     Term(..), 
     printTerm, 
     customPrintTerm, 
     customPrintTermBase,
     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
import Data.List        ( partition )
import Foreign.Storable

78
79
import IO

80
81
82
83
84
85
86
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
113
114
115
116
117
118
---------------------------------------------
-- * 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',_,_))
          [ Term (Char, b, c) (,,) ('a',_,_) [Term Char C# "a", Thunk, Thunk]
          , Thunk
          , Term (Char, e, f) (,,) ('b',_,_) [Term Char C# "b", Thunk, Thunk]]
-}

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
119
120
121
122
123
isFullyEvaluatedTerm :: Term -> Bool
isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt
isFullyEvaluatedTerm Suspension {}      = False
isFullyEvaluatedTerm Prim {}            = True

124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
instance Outputable (Term) where
 ppr = head . customPrintTerm customPrintTermBase

-------------------------------------------------------------------------
-- 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 
142
                       , infoPtr      :: Ptr ()
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
                       , infoTable    :: StgInfoTable
                       , ptrs         :: Array Int HValue
                        -- What would be the type here? HValue is ok? Should I build a Ptr?
                       , 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
160
161
162
163
164
165
getClosureData a =
   case unpackClosure# a of 
     (# iptr, ptrs, nptrs #) -> do
           itbl <- peek (Ptr iptr)
           let tipe = readCType (BCI.tipe itbl)
               elems = BCI.ptrs itbl 
166
               ptrsList = Array 0 (fromIntegral$ elems) ptrs
167
           ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs)
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
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
261

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
 | 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

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
262
-- * Traversals for Terms
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
294
295
296
297
298
299
300
-----------------------------------

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
----------------------------------

parensCond True  = parens
parensCond False = id
app_prec::Int
app_prec = 10

printTerm :: Term -> SDoc
printTerm Prim{value=value} = text value 
printTerm t@Term{} = printTerm1 0 t 
printTerm Suspension{bound_to=Nothing} =  char '_' -- <> ppr ct <> char '_'
301
302
303
printTerm Suspension{mb_ty=Just ty, bound_to=Just n}
  | Just _ <- splitFunTy_maybe ty = text "<function>"
  | otherwise = parens$ ppr n <> text "::" <> ppr ty 
304
305
306
307
308
309
310
311
312
313
314
315
316
317

printTerm1 p Term{dc=dc, subTerms=tt} 
{-  | dataConIsInfix dc, (t1:t2:tt') <- tt 
  = parens (printTerm1 True t1 <+> ppr dc <+> printTerm1 True ppr t2) 
    <+> hsep (map (printTerm1 True) tt) 
-}
  | null tt   = ppr dc
  | otherwise = parensCond (p > app_prec) 
                     (ppr dc <+> sep (map (printTerm1 (app_prec+1)) tt))

  where fixity   = undefined 

printTerm1 _ t = printTerm t

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

customPrintTermBase :: Monad m => (Int->Term-> m SDoc)->[Term->m (Maybe SDoc)]
customPrintTermBase showP =
  [ 
337
    test isTupleDC (liftM (parens . hcat . punctuate comma) . mapM (showP 0) . subTerms)
338
339
340
341
342
343
344
345
346
347
348
349
350
351
  , test (isDC consDataCon) (\Term{subTerms=[h,t]} -> doList h t)
  , test (isDC intDataCon)  (coerceShow$ \(a::Int)->a)
  , test (isDC charDataCon) (coerceShow$ \(a::Char)->a)
--  , test (isDC wordDataCon) (coerceShow$ \(a::Word)->a)
  , test (isDC floatDataCon) (coerceShow$ \(a::Float)->a)
  , test (isDC doubleDataCon) (coerceShow$ \(a::Double)->a)
  , test isIntegerDC (coerceShow$ \(a::Integer)->a)
  ] 
     where test pred f t = if pred t then liftM Just (f t) else return Nothing
           isIntegerDC Term{dc=dc} = 
              dataConName dc `elem` [ smallIntegerDataConName
                                    , largeIntegerDataConName] 
           isTupleDC Term{dc=dc}   = dc `elem` snd (unzip (elems boxedTupleArr))
           isDC a_dc Term{dc=dc}   = a_dc == dc
mnislaih's avatar
mnislaih committed
352
           coerceShow f = return . text . show . f . unsafeCoerce# . val
353
354
355
356
357
358
359
360
361
362
363
           --TODO pprinting of list terms is not lazy
           doList h t = do
               let elems = h : getListTerms t
                   isConsLast = isSuspension (last elems) && 
                                (mb_ty$ last elems) /= (termType h)
               init <- mapM (showP 0) (init elems) 
               last0 <- showP 0 (last elems)
               let last = case length elems of 
                            1 -> last0 
                            _ | isConsLast -> text " | " <> last0
                            _ -> comma <> last0
364
               return$ brackets (hcat (punctuate comma init ++ [last]))
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390

                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 ()
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
429
430
431
432
433
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
434
    | Just tv <- getTyVar_maybe rhs 
435
    = recoverM (return (lhs,rhs)) $ do  
436
         Indirect ty_v <- readMetaTyVar tv
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
         (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"
466
467
468
469
470
471
472
473
474
475
476
477

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

liftTcM = id

instScheme :: Type -> TR TcType
instScheme ty = liftTcM$ liftM trd (tcInstType (liftM fst3 . tcInstTyVars) ty)
    where fst3 (x,y,z) = x
          trd  (x,y,z) = z

cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
478
479
480
481
cvObtainTerm hsc_env force mb_ty a = do
   -- Obtain the term and tidy the type before returning it
   term <- cvObtainTerm1 hsc_env force mb_ty a
   return $ tidyTypes term
482
483
484
485
486
487
488
489
   where 
         tidyTypes = foldTerm idTermFold {
            fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt,
            fSuspension = \ct mb_ty hval n -> 
                          Suspension ct (fmap tidy mb_ty) hval n
            }
         tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty  
         tidyVarEnv ty = 
mnislaih's avatar
mnislaih committed
490

491
492
493
494
495
             mkVarEnv$ [ (v, setTyVarName v (tyVarName tv))
                         | (tv,v) <- zip alphaTyVars vars]
             where vars = varSetElems$ tyVarsOfType ty

cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term
496
497
498
499
500
cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
   tv   <- liftM mkTyVarTy (newVar argTypeKind)
   when (isJust mb_ty) $ 
        instScheme (sigmaType$ fromJust mb_ty) >>= addConstraint tv
   go tv hval
501
    where 
502
  go tv a = do 
503
504
    clos <- trIO $ getClosureData a
    case tipe clos of
505
-- Thunks we may want to force
506
      Thunk _ | force -> seq a $ go tv a
507
-- We always follow indirections 
508
      Indirection _ -> go tv $! (ptrs clos ! 0)
509
510
 -- The interesting case
      Constr -> do
511
        m_dc <- trIO$ tcRnRecoverDataCon hsc_env (infoPtr clos)
512
513
514
515
516
517
        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)
                subTtypes  = drop extra_args (dataConRepArgTys dc)
                (subTtypesP, subTtypesNP) = partition isPointed subTtypes
518
519
520
521
522
523
524
525
                n_subtermsP= length subTtypesP
            subTermTvs    <- mapM (liftM mkTyVarTy . newVar ) (map typeKind subTtypesP)
            baseType      <- instScheme (dataConRepType dc)
            let myType     = mkFunTys (reOrderTerms subTermTvs subTtypesNP subTtypes) tv
            addConstraint myType baseType
            subTermsP <- sequence [ extractSubterm i tv (ptrs clos) 
                                   | (i,tv) <- zip [extra_args..extra_args + n_subtermsP - 1]
                                                   subTermTvs ]
526
527
528
            let unboxeds   = extractUnboxed subTtypesNP (nonPtrs clos)
                subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)      
                subTerms   = reOrderTerms subTermsP subTermsNP subTtypes
529
            return (Term tv dc a subTerms)
530
531
-- The otherwise case: can be a Thunk,AP,PAP,etc.
      otherwise -> do
532
         return (Suspension (tipe clos) (Just tv) a Nothing)
533
534
535

-- 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 
536
  extractSubterm (I# i#) tv ptrs = case ptrs of 
537
                 (Array _ _ ptrs#) -> case indexArray# ptrs# i# of 
538
                       (# e #) -> go tv e
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554

-- This is used to put together pointed and nonpointed subterms in the 
--  correct order.
  reOrderTerms _ _ [] = []
  reOrderTerms pointed unpointed (ty:tys) 
   | isPointed ty = head pointed : reOrderTerms (tail pointed) unpointed tys
   | otherwise    = head unpointed : reOrderTerms pointed (tail unpointed) tys

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
555
556

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

560
561
562
563
564
565
566
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
{-
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
-}