Add code to print data in Haskell-Like syntax
[ghc-heap-view.git] / src / GHC / HeapView.hs
1 {-# LANGUAGE MagicHash, UnboxedTuples, CPP, ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes, BangPatterns, RecordWildCards, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
2 {-|
3 Module      :  GHC.HeapView
4 Copyright   :  (c) 2012 Joachim Breitner
5 License     :  BSD3
6 Maintainer  :  Joachim Breitner <mail@joachim-breitner.de>
7
8 With this module, you can investigate the heap representation of Haskell
9 values, i.e. to investigate sharing and lazy evaluation.
10 -}
11
12
13 module GHC.HeapView (
14     -- * Heap data types
15     GenClosure(..),
16     Closure,
17     allPtrs,
18     ClosureType(..),
19     StgInfoTable(..),
20     HalfWord,
21     -- * Pretty printing
22     prettyPrintClosure,
23     prettyDeeplyPrintClosure,
24     -- * Reading from the heap
25     getClosureData,
26     getBoxedClosureData,
27     getClosureRaw,
28     -- * Boxes
29     Box(..),
30     asBox,
31     -- * Weak boxes
32     WeakBox,
33     weakBox,
34     isAlive,
35     derefWeakBox,
36     WeakClosure,
37     weakenClosure,
38     )
39     where
40
41 import GHC.Exts         ( Any,
42                           Ptr(..), Addr#, Int(..), Word(..), Word#, Int#,
43                           ByteArray#, Array#, sizeofByteArray#, sizeofArray#, indexArray#, indexWordArray#,
44                           unsafeCoerce# )
45
46 import GHC.Arr          (Array(..))
47
48 import GHC.Constants    ( wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS )
49
50 import System.IO.Unsafe ( unsafePerformIO )
51
52 import Foreign          hiding ( unsafePerformIO )
53 import Numeric          ( showHex )
54 import Data.Char
55 import Data.List        ( intersperse, intercalate )
56 import Data.Maybe       ( isJust )
57 import System.Mem.Weak
58 import Data.Foldable    ( Foldable )
59 import Data.Traversable ( Traversable )
60 import qualified Data.Traversable as T
61
62 #include "ghcautoconf.h"
63
64 -- | An arbitrarily Haskell value in a safe Box. The point is that even
65 -- unevaluated thunks can safely be moved around inside the Box, and when
66 -- required, e.g. in 'getBoxedClosureData', the function knows how far it has
67 -- to evalue the argument.
68 data Box = Box Any
69
70 #if SIZEOF_VOID_P == 8
71 type HalfWord = Word32
72 #else
73 type HalfWord = Word16
74 #endif
75
76 instance Show Box where
77 -- From libraries/base/GHC/Ptr.lhs
78    showsPrec _ (Box a) rs =
79     -- unsafePerformIO (print "↓" >> pClosure a) `seq`    
80     pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs
81      where
82        ptr  = W# (aToWord# a)
83        tag  = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
84        addr = ptr - tag
85         -- want 0s prefixed to pad it out to a fixed length.
86        pad_out ls = 
87           '0':'x':(replicate (2*wORD_SIZE - length ls) '0') ++ ls
88
89 instance Eq Box where
90   Box a == Box b = case reallyUnsafePtrEqualityUpToTag# a b of
91     0# -> False
92     _  -> True
93
94 {-|
95   This takes an arbitrary value and puts it into a box. Note that calls like
96
97   > asBox (head list) 
98
99   will put the thunk \"head list\" into the box, /not/ the element at the head
100   of the list. For that, use careful case expressions:
101
102   > case list of x:_ -> asBox x
103 -}
104 asBox :: a -> Box
105 asBox x = Box (unsafeCoerce# x)
106
107 {-
108    StgInfoTable parsing derived from ByteCodeItbls.lhs
109    Removed the code parameter for now
110    Replaced Type by an enumeration
111    Remove stuff dependent on GHCI_TABLES_NEXT_TO_CODE
112  -}
113
114 {-| This is a somewhat faithful representation of an info table. See
115    <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/InfoTables.h>
116    for more details on this data structure. Note that the 'Storable' instance
117    provided here does _not_ support writing.
118  -}
119 data StgInfoTable = StgInfoTable {
120    ptrs   :: HalfWord,
121    nptrs  :: HalfWord,
122    tipe   :: ClosureType,
123    srtlen :: HalfWord
124   }
125   deriving (Show)
126
127 instance Storable StgInfoTable where
128
129    sizeOf itbl 
130       = sum
131         [
132          fieldSz ptrs itbl,
133          fieldSz nptrs itbl,
134          sizeOf (undefined :: HalfWord),
135          fieldSz srtlen itbl
136         ]
137
138    alignment _ 
139       = wORD_SIZE
140
141    poke _a0 _itbl
142       = error "Storable StgInfoTable is read-only"
143
144    peek a0
145       = runState (castPtr a0)
146       $ do
147            ptrs'   <- load
148            nptrs'  <- load
149            tipe'   <- load
150            srtlen' <- load
151            return 
152               StgInfoTable { 
153                  ptrs   = ptrs',
154                  nptrs  = nptrs',
155                  tipe   = toEnum (fromIntegral (tipe'::HalfWord)),
156                  srtlen = srtlen'
157               }
158
159 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
160 fieldSz sel x = sizeOf (sel x)
161
162 load :: Storable a => PtrIO a
163 load = do addr <- advance
164           lift (peek addr)
165
166 type PtrIO = State (Ptr Word8) IO
167
168 advance :: Storable a => PtrIO (Ptr a)
169 advance = State adv where
170     adv addr = case castPtr addr of { addrCast -> return
171         (addr `plusPtr` sizeOfPointee addrCast, addrCast) }
172
173 sizeOfPointee :: (Storable a) => Ptr a -> Int
174 sizeOfPointee addr = sizeOf (typeHack addr)
175     where typeHack = undefined :: Ptr a -> a
176
177 {-
178    Embedded StateT, also from ByteCodeItbls
179  -}
180
181 newtype State s m a = State (s -> m (s, a))
182
183 instance Monad m => Monad (State s m) where
184   return a      = State (\s -> return (s, a))
185   State m >>= k = State (\s -> m s >>= \(s', a) -> case k a of State n -> n s')
186   fail str      = State (\_ -> fail str)
187
188 lift :: Monad m => m a -> State s m a
189 lift m = State (\s -> m >>= \a -> return (s, a))
190
191 runState :: (Monad m) => s -> State s m a -> m a
192 runState s (State m) = m s >>= return . snd
193
194 {-
195    Data Type representing Closures
196  -}
197
198
199 {-| A closure type enumeration, in order matching the actual value on the heap.
200    Needs to be synchronized with
201    <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/ClosureTypes.h>
202  -}
203 data ClosureType =
204           INVALID_OBJECT
205         | CONSTR
206         | CONSTR_1_0
207         | CONSTR_0_1
208         | CONSTR_2_0
209         | CONSTR_1_1
210         | CONSTR_0_2
211         | CONSTR_STATIC
212         | CONSTR_NOCAF_STATIC
213         | FUN
214         | FUN_1_0
215         | FUN_0_1
216         | FUN_2_0
217         | FUN_1_1
218         | FUN_0_2
219         | FUN_STATIC
220         | THUNK
221         | THUNK_1_0
222         | THUNK_0_1
223         | THUNK_2_0
224         | THUNK_1_1
225         | THUNK_0_2
226         | THUNK_STATIC
227         | THUNK_SELECTOR
228         | BCO
229         | AP
230         | PAP
231         | AP_STACK
232         | IND
233         | IND_PERM
234         | IND_STATIC
235         | RET_BCO
236         | RET_SMALL
237         | RET_BIG
238         | RET_DYN
239         | RET_FUN
240         | UPDATE_FRAME
241         | CATCH_FRAME
242         | UNDERFLOW_FRAME
243         | STOP_FRAME
244         | BLOCKING_QUEUE
245         | BLACKHOLE
246         | MVAR_CLEAN
247         | MVAR_DIRTY
248         | ARR_WORDS
249         | MUT_ARR_PTRS_CLEAN
250         | MUT_ARR_PTRS_DIRTY
251         | MUT_ARR_PTRS_FROZEN0
252         | MUT_ARR_PTRS_FROZEN
253         | MUT_VAR_CLEAN
254         | MUT_VAR_DIRTY
255         | WEAK
256         | PRIM
257         | MUT_PRIM
258         | TSO
259         | STACK
260         | TREC_CHUNK
261         | ATOMICALLY_FRAME
262         | CATCH_RETRY_FRAME
263         | CATCH_STM_FRAME
264         | WHITEHOLE
265  deriving (Show, Eq, Enum, Ord)
266
267 {-| This is the main data type of this module, representing a Haskell value on
268   the heap. This reflects
269   <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/Closures.h>
270
271   The data type is parametrized by the type to store references in, which
272   should be either 'Box' or 'WeakBox', with appropriate type synonyms 'Closure'
273   and 'WeakClosure'.
274  -}
275 data GenClosure b =
276     ConsClosure {
277         info         :: StgInfoTable 
278         , ptrArgs    :: [b]
279         , dataArgs   :: [Word]
280         , pkg        :: String
281         , modl       :: String
282         , name       :: String
283     } |
284     ThunkClosure {
285         info         :: StgInfoTable 
286         , ptrArgs    :: [b]
287         , dataArgs   :: [Word]
288     } |
289     SelectorClosure {
290         info         :: StgInfoTable 
291         , selectee   :: b
292     } |
293     IndClosure {
294         info         :: StgInfoTable 
295         , indirectee   :: b
296     } |
297     BlackholeClosure {
298         info         :: StgInfoTable 
299         , indirectee   :: b
300     } |
301     APClosure {
302         info         :: StgInfoTable 
303         , arity      :: HalfWord
304         , n_args     :: HalfWord
305         , fun        :: b
306         , payload    :: [b]
307     } |
308     PAPClosure {
309         info         :: StgInfoTable 
310         , arity      :: HalfWord
311         , n_args     :: HalfWord
312         , fun        :: b
313         , payload    :: [b]
314     } |
315     APStackClosure {
316         info         :: StgInfoTable 
317         , fun        :: b
318         , payload    :: [b]
319     } |
320     BCOClosure {
321         info         :: StgInfoTable 
322         , instrs     :: b
323         , literals   :: b
324         , bcoptrs    :: b
325         , arity      :: HalfWord
326         , size       :: HalfWord
327         , bitmap     :: Word
328     } |
329     ArrWordsClosure {
330         info         :: StgInfoTable 
331         , bytes      :: Word
332         , arrWords   :: [Word]
333     } |
334     MutArrClosure {
335         info         :: StgInfoTable 
336         , mccPtrs    :: Word
337         , mccSize    :: Word
338         , mccPayload :: [b]
339         -- Card table ignored
340     } |
341     MutVarClosure {
342         info         :: StgInfoTable 
343         , var        :: b
344     } |
345     MVarClosure {
346         info         :: StgInfoTable 
347         , queueHead  :: b
348         , queueTail  :: b
349         , value      :: b
350     } |
351     FunClosure {
352         info         :: StgInfoTable 
353         , ptrArgs    :: [b]
354         , dataArgs   :: [Word]
355     } |
356     BlockingQueueClosure {
357         info         :: StgInfoTable 
358         , link       :: b
359         , blackHole  :: b
360         , owner      :: b
361         , queue      :: b
362     } |
363     OtherClosure {
364         info         :: StgInfoTable 
365         , hvalues    :: [b]
366         , rawWords   :: [Word]
367     } |
368     UnsupportedClosure {
369         info         :: StgInfoTable 
370     }
371  deriving (Show, Functor, Foldable, Traversable)
372
373
374 type Closure = GenClosure Box
375
376 -- | For generic code, this function returns all referenced closures. 
377 allPtrs :: GenClosure b -> [b]
378 allPtrs (ConsClosure {..}) = ptrArgs
379 allPtrs (ThunkClosure {..}) = ptrArgs
380 allPtrs (SelectorClosure {..}) = [selectee]
381 allPtrs (IndClosure {..}) = [indirectee]
382 allPtrs (BlackholeClosure {..}) = [indirectee]
383 allPtrs (APClosure {..}) = fun:payload
384 allPtrs (PAPClosure {..}) = fun:payload
385 allPtrs (APStackClosure {..}) = fun:payload
386 allPtrs (BCOClosure {..}) = [instrs,literals,bcoptrs]
387 allPtrs (ArrWordsClosure {..}) = []
388 allPtrs (MutArrClosure {..}) = mccPayload
389 allPtrs (MutVarClosure {..}) = [var]
390 allPtrs (MVarClosure {..}) = [queueHead,queueTail,value]
391 allPtrs (FunClosure {..}) = ptrArgs
392 allPtrs (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
393 allPtrs (OtherClosure {..}) = hvalues
394 allPtrs (UnsupportedClosure {..}) = []
395
396
397 -- | A pretty-printer that tries to generate valid Haskell for evalutated data.
398 -- It assumes that for the included boxes, you already replaced them by Strings
399 -- using 'Data.Foldable.map' or, if you need to do IO, 'Data.Foldable.mapM'.
400 --
401 -- The boolean parameter indicates whether braces should be added when the
402 -- result is an application, e.g. a non-nullary constructor.
403 prettyPrintClosure :: Bool -> GenClosure String -> String
404 prettyPrintClosure ab c = case c of
405     ConsClosure {..} -> addParens $
406         name : ptrArgs ++ map show dataArgs
407     ThunkClosure {..} -> addParens $
408         "_thunk" : ptrArgs ++ map show dataArgs
409     SelectorClosure {..} -> addParens
410         ["_sel", selectee]
411     IndClosure {..} -> addParens
412         ["_ind", indirectee]
413     BlackholeClosure {..} -> addParens
414         ["_bh", indirectee]
415     APClosure {..} -> addParens $
416         fun : payload
417     PAPClosure {..} -> addParens $
418         fun : payload
419     APStackClosure {..} -> addParens $
420         fun : payload
421     BCOClosure {..} -> addParens
422         ["_bco"]
423     ArrWordsClosure {..} -> addParens
424         ["toArray", intercalate "," (map show arrWords) ]
425     MutArrClosure {..} -> addParens
426         ["toMutArray", intercalate "," mccPayload]
427     MutVarClosure {..} -> addParens $
428         ["_mutVar", var]
429     MVarClosure {..} -> addParens $
430         ["MVar", value]
431     FunClosure {..} -> 
432         "_fun" ++ bracketize (ptrArgs ++ map show dataArgs)
433     BlockingQueueClosure {..} -> 
434         "_blockingQueue"
435     OtherClosure {..} ->
436         "_other"
437     UnsupportedClosure {..} ->
438         "_unsupported"
439   where
440     addParens [] = "()" -- not used
441     addParens [a] = a 
442     addParens xs = if ab
443                    then "(" ++ intercalate " " xs ++ ")"
444                    else intercalate " " xs 
445     bracketize [] = ""
446     bracketize xs = "[" ++ intercalate "," xs ++ "]"
447     
448 -- | Using 'prettyPrintClosure', prints a closure recursively. Will diverge for
449 -- cyclic or infinite input.
450 -- 
451 -- Example output for @[Just 4, Nothing]@:
452 --
453 -- > : (Just (I# 4)) (: Nothing [])
454 prettyDeeplyPrintClosure :: Closure -> IO String
455 prettyDeeplyPrintClosure c = prettyPrintClosure False `fmap` T.mapM printBox c
456   where
457     printBox b = do
458         c' <- getBoxedClosureData b
459         c'' <- T.mapM printBox c'
460         return $ prettyPrintClosure True c''
461
462
463 #ifdef PRIM_SUPPORTS_ANY
464 foreign import prim "aToWordzh" aToWord# :: Any -> Word#
465 foreign import prim "slurpClosurezh" slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
466 foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
467 #else
468 -- Workd-around code until http://hackage.haskell.org/trac/ghc/ticket/5931 was
469 -- accepted
470
471 -- foreign import prim "aToWordzh" aToWord'# :: Addr# -> Word#
472 foreign import prim "slurpClosurezh" slurpClosure'# :: Word#  -> (# Addr#, ByteArray#, Array# b #)
473
474 foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag'# :: Word# -> Word# -> Int#
475
476 -- This is a datatype that has the same layout as Ptr, so that by
477 -- unsafeCoerce'ing, we obtain the Addr of the wrapped value
478 data Ptr' a = Ptr' a
479
480 aToWord# :: Any -> Word#
481 aToWord# a = case Ptr' a of mb@(Ptr' _) -> case unsafeCoerce# mb :: Word of W# addr -> addr
482
483 slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
484 slurpClosure# a = slurpClosure'# (aToWord# a)
485
486 reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
487 reallyUnsafePtrEqualityUpToTag# a b = reallyUnsafePtrEqualityUpToTag'# (aToWord# a) (aToWord# b)
488 #endif
489
490 --pClosure x = do
491 --    getClosure x >>= print
492
493 -- | This returns the raw representation of the given argument. The second
494 -- component of the triple are the words on the heap, and the third component
495 -- are those words that are actually pointers. Once back in Haskell word, the
496 -- 'Word'  may be outdated after a garbage collector run, but the corresponding
497 -- 'Box' will still point to the correct value.
498 getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
499 getClosureRaw x =
500     case slurpClosure# (unsafeCoerce# x) of
501         (# iptr, dat, ptrs #) -> do
502             let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
503                 rawWords = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ]
504                 pelems = I# (sizeofArray# ptrs) 
505                 ptrList = amap' Box $ Array 0 (pelems - 1) pelems ptrs
506             ptrList `seq` rawWords `seq` return (Ptr iptr, rawWords, ptrList)
507
508 -- From compiler/ghci/RtClosureInspect.hs
509 amap' :: (t -> b) -> Array Int t -> [b]
510 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
511     where g (I# i#) = case indexArray# arr# i# of
512                           (# e #) -> f e
513
514 -- derived from vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs, which got it from
515 -- compiler/ghci/DebuggerUtils.hs
516 dataConInfoPtrToNames :: Ptr StgInfoTable -> IO (String, String, String)
517 dataConInfoPtrToNames ptr = do
518     conDescAddress <- getConDescAddress ptr
519     wl <- peekArray0 0 conDescAddress
520     let (pkg, modl, name) = parse wl
521     return (b2s pkg, b2s modl, b2s name)
522   where
523     b2s :: [Word8] -> String
524     b2s = fmap (chr . fromIntegral)
525
526     getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
527     getConDescAddress ptr'
528       | True = do
529           offsetToString <- peek (ptr' `plusPtr` (negate wORD_SIZE))
530           return $ (ptr' `plusPtr` stdInfoTableSizeB)
531                     `plusPtr` (fromIntegral (offsetToString :: Word))
532     -- This is code for !ghciTablesNextToCode: 
533     {-
534       | otherwise = peek . intPtrToPtr
535                       . (+ fromIntegral
536                             stdInfoTableSizeB)
537                         . ptrToIntPtr $ ptr
538     -}
539
540     -- hmmmmmm. Is there any way to tell this?
541     opt_SccProfilingOn = False
542
543     stdInfoTableSizeW :: Int
544     -- The size of a standard info table varies with profiling/ticky etc,
545     -- so we can't get it from Constants
546     -- It must vary in sync with mkStdInfoTable
547     stdInfoTableSizeW
548       = size_fixed + size_prof
549       where
550         size_fixed = 2  -- layout, type
551         size_prof | opt_SccProfilingOn = 2
552                   | otherwise    = 0
553
554     stdInfoTableSizeB :: Int
555     stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
556
557 -- From vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs
558 parse :: [Word8] -> ([Word8], [Word8], [Word8])
559 parse input = if not . all (>0) . fmap length $ [pkg,modl,occ]
560                 --then (error . concat)
561                 --        ["getConDescAddress:parse:"
562                 --        ,"(not . all (>0) . fmap le"
563                 --        ,"ngth $ [pkg,modl,occ]"]
564                 then ([], [], input) -- Not in the pkg.modl.occ format, for example END_TSO_QUEUE
565                 else (pkg, modl, occ)
566 --   = ASSERT (all (>0) (map length [pkg, modl, occ])) (pkg, modl, occ)   -- XXXXXXXXXXXXXXXX
567   where
568         (pkg, rest1) = break (== fromIntegral (ord ':')) input
569         (modl, occ)
570             = (concat $ intersperse [dot] $ reverse modWords, occWord)
571             where
572             (modWords, occWord) = if (length rest1 < 1) --  XXXXXXXXx YUKX
573                                     --then error "getConDescAddress:parse:length rest1 < 1"
574                                     then parseModOcc [] []
575                                     else parseModOcc [] (tail rest1)
576         -- ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
577         dot = fromIntegral (ord '.')
578         parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
579         parseModOcc acc str
580             = case break (== dot) str of
581                 (top, []) -> (acc, top)
582                 (top, _:bot) -> parseModOcc (top : acc) bot
583
584
585 -- | This function returns parsed heap representation of the argument _at this
586 -- moment_, even if it is unevaluated or an indirection or other exotic stuff.
587 -- Beware when passing something to this function, the same caveats as for
588 -- 'asBox' apply.
589 getClosureData :: a -> IO Closure
590 getClosureData x = do
591     (iptr, wds, ptrs) <- getClosureRaw x
592     itbl <- peek iptr
593     case tipe itbl of 
594         t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do
595             (pkg, modl, name) <- dataConInfoPtrToNames iptr
596             return $ ConsClosure itbl ptrs (drop (length ptrs + 1) wds) pkg modl name
597
598         t | t >= THUNK && t <= THUNK_STATIC -> do
599             return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) wds)
600
601         t | t >= FUN && t <= FUN_STATIC -> do
602             return $ FunClosure itbl ptrs (drop (length ptrs + 1) wds)
603
604         AP ->
605             return $ APClosure itbl 
606                 (fromIntegral $ wds !! 2)
607                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
608                 (head ptrs) (tail ptrs)
609
610         PAP ->
611             return $ PAPClosure itbl 
612                 (fromIntegral $ wds !! 2)
613                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
614                 (head ptrs) (tail ptrs)
615
616         AP_STACK ->
617             return $ APStackClosure itbl (head ptrs) (tail ptrs)
618
619         THUNK_SELECTOR ->
620             return $ SelectorClosure itbl (head ptrs)
621
622         IND ->
623             return $ IndClosure itbl (head ptrs)
624         IND_STATIC ->
625             return $ IndClosure itbl (head ptrs)
626         BLACKHOLE ->
627             return $ BlackholeClosure itbl (head ptrs)
628
629         BCO ->
630             return $ BCOClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
631                 (fromIntegral $ wds !! 4)
632                 (fromIntegral $ shiftR (wds !! 4) (wORD_SIZE_IN_BITS `div` 2))
633                 (wds !! 5)
634
635         ARR_WORDS ->
636             return $ ArrWordsClosure itbl (wds !! 1) (drop 2 wds)
637
638         t | t == MUT_ARR_PTRS_FROZEN || t == MUT_ARR_PTRS_FROZEN0 ->
639             return $ MutArrClosure itbl (wds !! 1) (wds !! 2) ptrs
640
641         t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
642             return $ MutVarClosure itbl (head ptrs)
643
644         t | t == MVAR_CLEAN || t == MVAR_DIRTY ->
645             return $ MVarClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
646
647         BLOCKING_QUEUE ->
648             return $ OtherClosure itbl ptrs wds
649         --    return $ BlockingQueueClosure itbl
650         --        (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3)
651
652         --  return $ OtherClosure itbl ptrs wds
653         --
654         _ ->
655             return $ UnsupportedClosure itbl
656
657 -- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
658 getBoxedClosureData :: Box -> IO Closure
659 getBoxedClosureData (Box a) = getClosureData a
660
661
662 -- | An a variant of 'Box' that does not keep the value alive.
663 -- 
664 -- Like 'Box', its 'Show' instance is highly unsafe.
665 newtype WeakBox = WeakBox (Weak Box)
666
667
668 type WeakClosure = GenClosure WeakBox
669
670 instance Show WeakBox where
671     showsPrec p (WeakBox w) rs = case unsafePerformIO (deRefWeak w) of
672         Nothing -> let txt = "(freed)" in
673                    replicate (2*wORD_SIZE - length txt) ' ' ++ txt ++ rs
674         Just b -> showsPrec p b rs
675
676 {-|
677   Turns a 'Box' into a 'WeakBox', allowing the referenced value to be garbage
678   collected.
679 -}
680 weakBox :: Box -> IO WeakBox
681 weakBox b@(Box a) = WeakBox `fmap` mkWeak a b Nothing
682
683 {-|
684   Checks whether the value referenced by a weak box is still alive
685 -}
686 isAlive :: WeakBox -> IO Bool
687 isAlive (WeakBox w) = isJust `fmap` deRefWeak w
688
689 {-|
690   Dereferences the weak box
691 -}
692 derefWeakBox :: WeakBox -> IO (Maybe Box)
693 derefWeakBox (WeakBox w) = deRefWeak w
694
695 weakenClosure :: Closure -> IO WeakClosure
696 weakenClosure = T.mapM weakBox