Improve haddock wording
[ghc-heap-view.git] / src / GHC / HeapView.hs
1 {-# LANGUAGE MagicHash, UnboxedTuples, CPP, ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes, BangPatterns, RecordWildCards, DeriveFunctor, DeriveFoldable, DeriveTraversable, PatternGuards #-}
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     -- * Reading from the heap
22     getClosureData,
23     getBoxedClosureData,
24     getClosureRaw,
25     -- * Pretty printing
26     ppClosure,
27     -- * Heap maps
28     -- $heapmap
29     HeapTree(..),
30     buildHeapTree,
31     ppHeapTree,
32     HeapGraphEntry(..),
33     HeapGraphIndex,
34     HeapGraph(..),
35     lookupHeapGraph,
36     heapGraphRoot,
37     buildHeapGraph,
38     multiBuildHeapGraph,
39     addHeapGraph,
40     ppHeapGraph,
41     -- * Boxes
42     Box(..),
43     asBox,
44     -- * Weak boxes
45     WeakBox,
46     weakBox,
47     isAlive,
48     derefWeakBox,
49     WeakClosure,
50     weakenClosure,
51     )
52     where
53
54 import GHC.Exts         ( Any,
55                           Ptr(..), Addr#, Int(..), Word(..), Word#, Int#,
56                           ByteArray#, Array#, sizeofByteArray#, sizeofArray#, indexArray#, indexWordArray#,
57                           unsafeCoerce# )
58
59 import GHC.Arr          (Array(..))
60
61 import GHC.Constants    ( wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS )
62
63 import System.IO.Unsafe ( unsafePerformIO )
64
65 import Foreign          hiding ( unsafePerformIO )
66 import Numeric          ( showHex )
67 import Data.Char
68 import Data.List
69 import Data.Maybe       ( isJust, catMaybes )
70 import Data.Tuple       ( swap )
71 import System.Mem.Weak
72 import Data.Functor
73 import Data.Function
74 import Data.Foldable    ( Foldable )
75 import Data.Traversable ( Traversable )
76 import qualified Data.Traversable as T
77 import qualified Data.IntMap as M
78 import Control.Monad
79 import Control.Monad.Trans.State
80 import Control.Monad.Trans.Class
81 import Control.Monad.IO.Class
82 import Control.Monad.Trans.Writer.Strict
83
84 #include "ghcautoconf.h"
85
86 -- | An arbitrarily Haskell value in a safe Box. The point is that even
87 -- unevaluated thunks can safely be moved around inside the Box, and when
88 -- required, e.g. in 'getBoxedClosureData', the function knows how far it has
89 -- to evalue the argument.
90 data Box = Box Any
91
92 #if SIZEOF_VOID_P == 8
93 type HalfWord = Word32
94 #else
95 type HalfWord = Word16
96 #endif
97
98 instance Show Box where
99 -- From libraries/base/GHC/Ptr.lhs
100    showsPrec _ (Box a) rs =
101     -- unsafePerformIO (print "↓" >> pClosure a) `seq`    
102     pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs
103      where
104        ptr  = W# (aToWord# a)
105        tag  = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
106        addr = ptr - tag
107         -- want 0s prefixed to pad it out to a fixed length.
108        pad_out ls = 
109           '0':'x':(replicate (2*wORD_SIZE - length ls) '0') ++ ls
110
111 instance Eq Box where
112   Box a == Box b = case reallyUnsafePtrEqualityUpToTag# a b of
113     0# -> False
114     _  -> True
115
116 {-|
117   This takes an arbitrary value and puts it into a box. Note that calls like
118
119   > asBox (head list) 
120
121   will put the thunk \"head list\" into the box, /not/ the element at the head
122   of the list. For that, use careful case expressions:
123
124   > case list of x:_ -> asBox x
125 -}
126 asBox :: a -> Box
127 asBox x = Box (unsafeCoerce# x)
128
129 {-
130    StgInfoTable parsing derived from ByteCodeItbls.lhs
131    Removed the code parameter for now
132    Replaced Type by an enumeration
133    Remove stuff dependent on GHCI_TABLES_NEXT_TO_CODE
134  -}
135
136 {-| This is a somewhat faithful representation of an info table. See
137    <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/InfoTables.h>
138    for more details on this data structure. Note that the 'Storable' instance
139    provided here does _not_ support writing.
140  -}
141 data StgInfoTable = StgInfoTable {
142    ptrs   :: HalfWord,
143    nptrs  :: HalfWord,
144    tipe   :: ClosureType,
145    srtlen :: HalfWord
146   }
147   deriving (Show)
148
149 instance Storable StgInfoTable where
150
151    sizeOf itbl 
152       = sum
153         [
154          fieldSz ptrs itbl,
155          fieldSz nptrs itbl,
156          sizeOf (undefined :: HalfWord),
157          fieldSz srtlen itbl
158         ]
159
160    alignment _ 
161       = wORD_SIZE
162
163    poke _a0 _itbl
164       = error "Storable StgInfoTable is read-only"
165
166    peek a0
167       = flip (evalStateT) (castPtr a0)
168       $ do
169            ptrs'   <- load
170            nptrs'  <- load
171            tipe'   <- load
172            srtlen' <- load
173            return 
174               StgInfoTable { 
175                  ptrs   = ptrs',
176                  nptrs  = nptrs',
177                  tipe   = toEnum (fromIntegral (tipe'::HalfWord)),
178                  srtlen = srtlen'
179               }
180
181 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
182 fieldSz sel x = sizeOf (sel x)
183
184 load :: Storable a => PtrIO a
185 load = do addr <- advance
186           lift (peek addr)
187
188 type PtrIO = StateT (Ptr Word8) IO
189
190 advance :: Storable a => PtrIO (Ptr a)
191 advance = StateT adv where
192     adv addr = case castPtr addr of { addrCast -> return
193         (addrCast, addr `plusPtr` sizeOfPointee addrCast) }
194
195 sizeOfPointee :: (Storable a) => Ptr a -> Int
196 sizeOfPointee addr = sizeOf (typeHack addr)
197     where typeHack = undefined :: Ptr a -> a
198
199 {-
200    Data Type representing Closures
201  -}
202
203
204 {-| A closure type enumeration, in order matching the actual value on the heap.
205    Needs to be synchronized with
206    <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/ClosureTypes.h>
207  -}
208 data ClosureType =
209           INVALID_OBJECT
210         | CONSTR
211         | CONSTR_1_0
212         | CONSTR_0_1
213         | CONSTR_2_0
214         | CONSTR_1_1
215         | CONSTR_0_2
216         | CONSTR_STATIC
217         | CONSTR_NOCAF_STATIC
218         | FUN
219         | FUN_1_0
220         | FUN_0_1
221         | FUN_2_0
222         | FUN_1_1
223         | FUN_0_2
224         | FUN_STATIC
225         | THUNK
226         | THUNK_1_0
227         | THUNK_0_1
228         | THUNK_2_0
229         | THUNK_1_1
230         | THUNK_0_2
231         | THUNK_STATIC
232         | THUNK_SELECTOR
233         | BCO
234         | AP
235         | PAP
236         | AP_STACK
237         | IND
238         | IND_PERM
239         | IND_STATIC
240         | RET_BCO
241         | RET_SMALL
242         | RET_BIG
243         | RET_DYN
244         | RET_FUN
245         | UPDATE_FRAME
246         | CATCH_FRAME
247         | UNDERFLOW_FRAME
248         | STOP_FRAME
249         | BLOCKING_QUEUE
250         | BLACKHOLE
251         | MVAR_CLEAN
252         | MVAR_DIRTY
253         | ARR_WORDS
254         | MUT_ARR_PTRS_CLEAN
255         | MUT_ARR_PTRS_DIRTY
256         | MUT_ARR_PTRS_FROZEN0
257         | MUT_ARR_PTRS_FROZEN
258         | MUT_VAR_CLEAN
259         | MUT_VAR_DIRTY
260         | WEAK
261         | PRIM
262         | MUT_PRIM
263         | TSO
264         | STACK
265         | TREC_CHUNK
266         | ATOMICALLY_FRAME
267         | CATCH_RETRY_FRAME
268         | CATCH_STM_FRAME
269         | WHITEHOLE
270  deriving (Show, Eq, Enum, Ord)
271
272 {-| This is the main data type of this module, representing a Haskell value on
273   the heap. This reflects
274   <http://hackage.haskell.org/trac/ghc/browser/includes/rts/storage/Closures.h>
275
276   The data type is parametrized by the type to store references in, which
277   should be either 'Box' or 'WeakBox', with appropriate type synonyms 'Closure'
278   and 'WeakClosure'.
279  -}
280 data GenClosure b =
281     ConsClosure {
282         info         :: StgInfoTable 
283         , ptrArgs    :: [b]
284         , dataArgs   :: [Word]
285         , pkg        :: String
286         , modl       :: String
287         , name       :: String
288     } |
289     ThunkClosure {
290         info         :: StgInfoTable 
291         , ptrArgs    :: [b]
292         , dataArgs   :: [Word]
293     } |
294     SelectorClosure {
295         info         :: StgInfoTable 
296         , selectee   :: b
297     } |
298     IndClosure {
299         info         :: StgInfoTable 
300         , indirectee   :: b
301     } |
302     BlackholeClosure {
303         info         :: StgInfoTable 
304         , indirectee   :: b
305     } |
306     -- In GHCi, if Linker.h would allow a reverse looup, we could for exported
307     -- functions fun actually find the name here.
308     -- At least the other direction works via "lookupSymbol
309     -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags)
310     APClosure {
311         info         :: StgInfoTable 
312         , arity      :: HalfWord
313         , n_args     :: HalfWord
314         , fun        :: b
315         , payload    :: [b]
316     } |
317     PAPClosure {
318         info         :: StgInfoTable 
319         , arity      :: HalfWord
320         , n_args     :: HalfWord
321         , fun        :: b
322         , payload    :: [b]
323     } |
324     APStackClosure {
325         info         :: StgInfoTable 
326         , fun        :: b
327         , payload    :: [b]
328     } |
329     BCOClosure {
330         info         :: StgInfoTable 
331         , instrs     :: b
332         , literals   :: b
333         , bcoptrs    :: b
334         , arity      :: HalfWord
335         , size       :: HalfWord
336         , bitmap     :: Word
337     } |
338     ArrWordsClosure {
339         info         :: StgInfoTable 
340         , bytes      :: Word
341         , arrWords   :: [Word]
342     } |
343     MutArrClosure {
344         info         :: StgInfoTable 
345         , mccPtrs    :: Word
346         , mccSize    :: Word
347         , mccPayload :: [b]
348         -- Card table ignored
349     } |
350     MutVarClosure {
351         info         :: StgInfoTable 
352         , var        :: b
353     } |
354     MVarClosure {
355         info         :: StgInfoTable 
356         , queueHead  :: b
357         , queueTail  :: b
358         , value      :: b
359     } |
360     FunClosure {
361         info         :: StgInfoTable 
362         , ptrArgs    :: [b]
363         , dataArgs   :: [Word]
364     } |
365     BlockingQueueClosure {
366         info         :: StgInfoTable 
367         , link       :: b
368         , blackHole  :: b
369         , owner      :: b
370         , queue      :: b
371     } |
372     OtherClosure {
373         info         :: StgInfoTable 
374         , hvalues    :: [b]
375         , rawWords   :: [Word]
376     } |
377     UnsupportedClosure {
378         info         :: StgInfoTable 
379     }
380  deriving (Show, Functor, Foldable, Traversable)
381
382
383 type Closure = GenClosure Box
384
385 -- | For generic code, this function returns all referenced closures. 
386 allPtrs :: GenClosure b -> [b]
387 allPtrs (ConsClosure {..}) = ptrArgs
388 allPtrs (ThunkClosure {..}) = ptrArgs
389 allPtrs (SelectorClosure {..}) = [selectee]
390 allPtrs (IndClosure {..}) = [indirectee]
391 allPtrs (BlackholeClosure {..}) = [indirectee]
392 allPtrs (APClosure {..}) = fun:payload
393 allPtrs (PAPClosure {..}) = fun:payload
394 allPtrs (APStackClosure {..}) = fun:payload
395 allPtrs (BCOClosure {..}) = [instrs,literals,bcoptrs]
396 allPtrs (ArrWordsClosure {..}) = []
397 allPtrs (MutArrClosure {..}) = mccPayload
398 allPtrs (MutVarClosure {..}) = [var]
399 allPtrs (MVarClosure {..}) = [queueHead,queueTail,value]
400 allPtrs (FunClosure {..}) = ptrArgs
401 allPtrs (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
402 allPtrs (OtherClosure {..}) = hvalues
403 allPtrs (UnsupportedClosure {..}) = []
404
405
406 #ifdef PRIM_SUPPORTS_ANY
407 foreign import prim "aToWordzh" aToWord# :: Any -> Word#
408 foreign import prim "slurpClosurezh" slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
409 foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
410 #else
411 -- Workd-around code until http://hackage.haskell.org/trac/ghc/ticket/5931 was
412 -- accepted
413
414 -- foreign import prim "aToWordzh" aToWord'# :: Addr# -> Word#
415 foreign import prim "slurpClosurezh" slurpClosure'# :: Word#  -> (# Addr#, ByteArray#, Array# b #)
416
417 foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag'# :: Word# -> Word# -> Int#
418
419 -- This is a datatype that has the same layout as Ptr, so that by
420 -- unsafeCoerce'ing, we obtain the Addr of the wrapped value
421 data Ptr' a = Ptr' a
422
423 aToWord# :: Any -> Word#
424 aToWord# a = case Ptr' a of mb@(Ptr' _) -> case unsafeCoerce# mb :: Word of W# addr -> addr
425
426 slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
427 slurpClosure# a = slurpClosure'# (aToWord# a)
428
429 reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
430 reallyUnsafePtrEqualityUpToTag# a b = reallyUnsafePtrEqualityUpToTag'# (aToWord# a) (aToWord# b)
431 #endif
432
433 --pClosure x = do
434 --    getClosure x >>= print
435
436 -- | This returns the raw representation of the given argument. The second
437 -- component of the triple are the words on the heap, and the third component
438 -- are those words that are actually pointers. Once back in Haskell word, the
439 -- 'Word'  may be outdated after a garbage collector run, but the corresponding
440 -- 'Box' will still point to the correct value.
441 getClosureRaw :: a -> IO (Ptr StgInfoTable, [Word], [Box])
442 getClosureRaw x =
443     case slurpClosure# (unsafeCoerce# x) of
444         (# iptr, dat, ptrs #) -> do
445             let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
446                 rawWords = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ]
447                 pelems = I# (sizeofArray# ptrs) 
448                 ptrList = amap' Box $ Array 0 (pelems - 1) pelems ptrs
449             ptrList `seq` rawWords `seq` return (Ptr iptr, rawWords, ptrList)
450
451 -- From compiler/ghci/RtClosureInspect.hs
452 amap' :: (t -> b) -> Array Int t -> [b]
453 amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
454     where g (I# i#) = case indexArray# arr# i# of
455                           (# e #) -> f e
456
457 -- derived from vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs, which got it from
458 -- compiler/ghci/DebuggerUtils.hs
459 dataConInfoPtrToNames :: Ptr StgInfoTable -> IO (String, String, String)
460 dataConInfoPtrToNames ptr = do
461     conDescAddress <- getConDescAddress ptr
462     wl <- peekArray0 0 conDescAddress
463     let (pkg, modl, name) = parse wl
464     return (b2s pkg, b2s modl, b2s name)
465   where
466     b2s :: [Word8] -> String
467     b2s = fmap (chr . fromIntegral)
468
469     getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
470     getConDescAddress ptr'
471       | True = do
472           offsetToString <- peek (ptr' `plusPtr` (negate wORD_SIZE))
473           return $ (ptr' `plusPtr` stdInfoTableSizeB)
474                     `plusPtr` (fromIntegral (offsetToString :: Word))
475     -- This is code for !ghciTablesNextToCode: 
476     {-
477       | otherwise = peek . intPtrToPtr
478                       . (+ fromIntegral
479                             stdInfoTableSizeB)
480                         . ptrToIntPtr $ ptr
481     -}
482
483     -- hmmmmmm. Is there any way to tell this?
484     opt_SccProfilingOn = False
485
486     stdInfoTableSizeW :: Int
487     -- The size of a standard info table varies with profiling/ticky etc,
488     -- so we can't get it from Constants
489     -- It must vary in sync with mkStdInfoTable
490     stdInfoTableSizeW
491       = size_fixed + size_prof
492       where
493         size_fixed = 2  -- layout, type
494         size_prof | opt_SccProfilingOn = 2
495                   | otherwise    = 0
496
497     stdInfoTableSizeB :: Int
498     stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
499
500 -- From vacuum-1.0.0.2/src/GHC/Vacuum/Internal.hs
501 parse :: [Word8] -> ([Word8], [Word8], [Word8])
502 parse input = if not . all (>0) . fmap length $ [pkg,modl,occ]
503                 --then (error . concat)
504                 --        ["getConDescAddress:parse:"
505                 --        ,"(not . all (>0) . fmap le"
506                 --        ,"ngth $ [pkg,modl,occ]"]
507                 then ([], [], input) -- Not in the pkg.modl.occ format, for example END_TSO_QUEUE
508                 else (pkg, modl, occ)
509 --   = ASSERT (all (>0) (map length [pkg, modl, occ])) (pkg, modl, occ)   -- XXXXXXXXXXXXXXXX
510   where
511         (pkg, rest1) = break (== fromIntegral (ord ':')) input
512         (modl, occ)
513             = (concat $ intersperse [dot] $ reverse modWords, occWord)
514             where
515             (modWords, occWord) = if (length rest1 < 1) --  XXXXXXXXx YUKX
516                                     --then error "getConDescAddress:parse:length rest1 < 1"
517                                     then parseModOcc [] []
518                                     else parseModOcc [] (tail rest1)
519         -- ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
520         dot = fromIntegral (ord '.')
521         parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
522         parseModOcc acc str
523             = case break (== dot) str of
524                 (top, []) -> (acc, top)
525                 (top, _:bot) -> parseModOcc (top : acc) bot
526
527
528 -- | This function returns parsed heap representation of the argument _at this
529 -- moment_, even if it is unevaluated or an indirection or other exotic stuff.
530 -- Beware when passing something to this function, the same caveats as for
531 -- 'asBox' apply.
532 getClosureData :: a -> IO Closure
533 getClosureData x = do
534     (iptr, wds, ptrs) <- getClosureRaw x
535     itbl <- peek iptr
536     case tipe itbl of 
537         t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do
538             (pkg, modl, name) <- dataConInfoPtrToNames iptr
539             return $ ConsClosure itbl ptrs (drop (length ptrs + 1) wds) pkg modl name
540
541         t | t >= THUNK && t <= THUNK_STATIC -> do
542             return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) wds)
543
544         t | t >= FUN && t <= FUN_STATIC -> do
545             return $ FunClosure itbl ptrs (drop (length ptrs + 1) wds)
546
547         AP ->
548             return $ APClosure itbl 
549                 (fromIntegral $ wds !! 2)
550                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
551                 (head ptrs) (tail ptrs)
552
553         PAP ->
554             return $ PAPClosure itbl 
555                 (fromIntegral $ wds !! 2)
556                 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
557                 (head ptrs) (tail ptrs)
558
559         AP_STACK ->
560             return $ APStackClosure itbl (head ptrs) (tail ptrs)
561
562         THUNK_SELECTOR ->
563             return $ SelectorClosure itbl (head ptrs)
564
565         IND ->
566             return $ IndClosure itbl (head ptrs)
567         IND_STATIC ->
568             return $ IndClosure itbl (head ptrs)
569         BLACKHOLE ->
570             return $ BlackholeClosure itbl (head ptrs)
571
572         BCO ->
573             return $ BCOClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
574                 (fromIntegral $ wds !! 4)
575                 (fromIntegral $ shiftR (wds !! 4) (wORD_SIZE_IN_BITS `div` 2))
576                 (wds !! 5)
577
578         ARR_WORDS ->
579             return $ ArrWordsClosure itbl (wds !! 1) (drop 2 wds)
580
581         t | t == MUT_ARR_PTRS_FROZEN || t == MUT_ARR_PTRS_FROZEN0 ->
582             return $ MutArrClosure itbl (wds !! 1) (wds !! 2) ptrs
583
584         t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
585             return $ MutVarClosure itbl (head ptrs)
586
587         t | t == MVAR_CLEAN || t == MVAR_DIRTY ->
588             return $ MVarClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
589
590         BLOCKING_QUEUE ->
591             return $ OtherClosure itbl ptrs wds
592         --    return $ BlockingQueueClosure itbl
593         --        (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3)
594
595         --  return $ OtherClosure itbl ptrs wds
596         --
597         _ ->
598             return $ UnsupportedClosure itbl
599
600 -- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
601 getBoxedClosureData :: Box -> IO Closure
602 getBoxedClosureData (Box a) = getClosureData a
603
604
605 isChar :: GenClosure b -> Maybe Char
606 isChar (ConsClosure { name = "C#", dataArgs = [ch], ptrArgs = []}) = Just (chr (fromIntegral ch))
607 isChar _ = Nothing
608
609 isCons :: GenClosure b -> Maybe (b, b)
610 isCons (ConsClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t)
611 isCons _ = Nothing
612
613 isTup :: GenClosure b -> Maybe [b]
614 isTup (ConsClosure { dataArgs = [], ..}) =
615     if length name >= 3 &&
616        head name == '(' && last name == ')' &&
617        all (==',') (tail (init name))
618     then Just ptrArgs else Nothing
619 isTup _ = Nothing
620
621
622 isNil :: GenClosure b -> Bool
623 isNil (ConsClosure { name = "[]", dataArgs = [], ptrArgs = []}) = True
624 isNil _ = False
625
626 -- | A pretty-printer that tries to generate valid Haskell for evalutated data.
627 -- It assumes that for the included boxes, you already replaced them by Strings
628 -- using 'Data.Foldable.map' or, if you need to do IO, 'Data.Foldable.mapM'.
629 --
630 -- The parameter gives the precedendence, to avoid avoidable parenthesises.
631 ppClosure :: (Int -> b -> String) -> Int -> GenClosure b -> String
632 ppClosure showBox prec c = case c of
633     _ | Just ch <- isChar c -> app $
634         ["C#", show ch]
635     _ | Just (h,t) <- isCons c -> addBraces (5 <= prec) $
636         showBox 5 h ++ " : " ++ showBox 4 t
637     _ | Just vs <- isTup c ->
638         "(" ++ intercalate "," (map (showBox 0) vs) ++ ")"
639     ConsClosure {..} -> app $
640         name : map (showBox 10) ptrArgs ++ map show dataArgs
641     ThunkClosure {..} -> app $
642         "_thunk" : map (showBox 10) ptrArgs ++ map show dataArgs
643     SelectorClosure {..} -> app
644         ["_sel", showBox 10 selectee]
645     IndClosure {..} -> app
646         ["_ind", showBox 10 indirectee]
647     BlackholeClosure {..} -> app
648         ["_bh",  showBox 10 indirectee]
649     APClosure {..} -> app $ map (showBox 10) $
650         fun : payload
651     PAPClosure {..} -> app $ map (showBox 10) $
652         fun : payload
653     APStackClosure {..} -> app $ map (showBox 10) $
654         fun : payload
655     BCOClosure {..} -> app
656         ["_bco"]
657     ArrWordsClosure {..} -> app
658         ["toArray", intercalate "," (map show arrWords) ]
659     MutArrClosure {..} -> app
660         ["toMutArray", intercalate "," (map (showBox 10) mccPayload)]
661     MutVarClosure {..} -> app $
662         ["_mutVar", (showBox 10) var]
663     MVarClosure {..} -> app $
664         ["MVar", (showBox 10) value]
665     FunClosure {..} -> 
666         "_fun" ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs)
667     BlockingQueueClosure {..} -> 
668         "_blockingQueue"
669     OtherClosure {..} ->
670         "_other"
671     UnsupportedClosure {..} ->
672         "_unsupported"
673   where
674     addBraces True t = "(" ++ t ++ ")"
675     addBraces False t = t
676     app [] = "()"
677     app [a] = a 
678     app xs = addBraces (10 <= prec) (intercalate " " xs)
679     braceize [] = ""
680     braceize xs = "{" ++ intercalate "," xs ++ "}"
681     
682 -- $heapmap
683 -- For more global views of the heap, you can use heap maps. These come in
684 -- variations, either a trees or as graphs, depending on
685 -- whether you want to detect cycles and sharing or not.
686
687 -- | Heap maps as tree, i.e. no sharing, no cycles.
688 data HeapTree = HeapTree WeakBox (GenClosure HeapTree) | EndOfHeapTree
689
690 heapTreeClosure :: HeapTree -> Maybe (GenClosure HeapTree)
691 heapTreeClosure (HeapTree _ c) = Just c
692 heapTreeClosure EndOfHeapTree = Nothing
693
694 -- | Constructing an 'HeapTree' from a boxed value. It takes a depth parameter
695 -- that prevents it from running ad infinitum for cyclic or infinite
696 -- structures.
697 buildHeapTree :: Int -> Box -> IO HeapTree
698 buildHeapTree 0 _ = do
699     return $ EndOfHeapTree
700 buildHeapTree n b = do
701     w <- weakBox b
702     c <- getBoxedClosureData b
703     c' <- T.mapM (buildHeapTree (n-1)) c
704     return $ HeapTree w c'
705
706 -- | Pretty-Printing a heap Tree
707 -- 
708 -- Example output for @[Just 4, Nothing, *something*]@, where *something* is an
709 -- unevaluated expression depending on the command line argument.
710 --
711 -- >[Just (I# 4),Nothing,Just (_thunk ["arg1","arg2"])]
712 ppHeapTree :: HeapTree -> String
713 ppHeapTree = go 0
714   where
715     go _ EndOfHeapTree = "..."
716     go prec t@(HeapTree _ c')
717         | Just s <- isHeapTreeString t = show s
718         | Just l <- isHeapTreeList t   = "[" ++ intercalate "," (map ppHeapTree l) ++ "]"
719         | otherwise                    =  ppClosure go prec c'
720
721 isHeapTreeList :: HeapTree -> Maybe ([HeapTree])
722 isHeapTreeList tree = do
723     c <- heapTreeClosure tree
724     if isNil c
725       then return []
726       else do
727         (h,t) <- isCons c
728         t' <- isHeapTreeList t
729         return $ (:) h t'
730
731 isHeapTreeString :: HeapTree -> Maybe String
732 isHeapTreeString t = do
733     list <- isHeapTreeList t
734     -- We do not want to print empty lists as "" as we do not know that they
735     -- are really strings.
736     if (null list)
737         then Nothing
738         else mapM (isChar <=< heapTreeClosure) list
739
740 -- | For heap graphs, i.e. data structures that also represent sharing and
741 -- cyclic structures, these are the entries. If the referenced value is
742 -- @Nothing@, then we do not have that value in the map, most likely due to
743 -- exceeding the recursion bound passed to 'buildHeapGraph'.
744 data HeapGraphEntry = HeapGraphEntry WeakBox (GenClosure (Maybe HeapGraphIndex))
745     deriving (Show)
746 type HeapGraphIndex = Int
747
748 -- | The whole graph. The suggested interface is to only use 'lookupHeapGraph',
749 -- as the internal representation may change. Nevertheless, we export it here:
750 -- Sometimes the user knows better what he needs than we do.
751 newtype HeapGraph = HeapGraph (M.IntMap HeapGraphEntry)
752     deriving (Show)
753
754 lookupHeapGraph :: HeapGraphIndex -> HeapGraph -> Maybe HeapGraphEntry
755 lookupHeapGraph i (HeapGraph m) = M.lookup i m
756
757 heapGraphRoot :: HeapGraphIndex
758 heapGraphRoot = 0
759
760 -- | Creates a 'HeapGraph' for the value in the box, but not recursing further
761 -- than the given limit. The initial value has index 'heapGraphRoot'.
762 buildHeapGraph :: Int -> Box -> IO HeapGraph
763 buildHeapGraph limit initialBox = fst <$> generalBuildHeapGraph [] [0..] limit [((),initialBox)]
764
765 -- | Creates a 'HeapGraph' for the values in multiple boxes, but not recursing
766 --   further than the given limit.
767 --
768 --   Returns the 'HeapGraph' and the indices of initial values. The arbitrary
769 --   type @a@ can be used to make the connection between the input and the
770 --   resulting list of indices.
771 multiBuildHeapGraph :: Int -> [(a, Box)] -> IO (HeapGraph, [(a, HeapGraphIndex)])
772 multiBuildHeapGraph = generalBuildHeapGraph [] [0..]
773
774 -- | Adds an entry to an existing 'HeapGraph'.
775 --
776 --   Returns the updated 'HeapGraph' and the index of the added value.
777 addHeapGraph :: HeapGraph -> Int -> Box -> IO (HeapGraphIndex, HeapGraph)
778 addHeapGraph (HeapGraph hg) limit initialBox = do
779     newStart <- foldM toStartList [] $ M.toList hg
780     let newIndex = 1 + (maximum $ map snd newStart)
781     (HeapGraph newHG, _) <- generalBuildHeapGraph newStart [newIndex..] limit [((),initialBox)]
782     return $ (newIndex, HeapGraph $ M.union hg newHG)
783   where toStartList xs (i, HeapGraphEntry wb _) = do
784             derefWeakBox wb >>= \mbB -> return $ case mbB of
785               Nothing -> xs
786               Just b  -> (b,i):xs
787
788 generalBuildHeapGraph :: [(Box, HeapGraphIndex)] -> [HeapGraphIndex] -> Int -> [(a,Box)] -> IO (HeapGraph, [(a, HeapGraphIndex)])
789 generalBuildHeapGraph _ _ limit _ | limit <= 0 = error "buildHeapGraph: limit has to be positive"
790 generalBuildHeapGraph knownEntries newIndices limit initialBoxes = do
791     let initialState = (knownEntries, newIndices, [])
792     (is, hg) <- runWriterT (evalStateT run initialState)
793     return (HeapGraph hg, is)
794   where
795     run = do
796         _ <- mapM (add limit) $ map snd initialBoxes
797         (_,_,is) <- get
798         return is
799
800     add 0 _ = return Nothing
801     add n b = do
802         -- If the box is in the map, return the index
803         (existing,_,_) <- get
804         case lookup b existing of
805             Just i -> return $ Just i
806             Nothing -> do
807                 -- Otherwise, allocate a new index
808                 i <- nextI
809                 -- And register it
810                 modify (\(x,y,z) -> ((b,i):x, y, z))
811                 c <- liftIO $ getBoxedClosureData b
812                 -- Find indicies for all boxes contained in the map
813                 c' <- T.mapM (add (n-1)) c
814                 w <- liftIO $ weakBox b
815                 -- Add add the resulting closure to the map
816                 lift $ tell (M.singleton i (HeapGraphEntry w c'))
817                 case initialLookup b of
818                   Nothing  -> return ()
819                   Just val -> modify (\(x,y,z) -> (x,y,(val,i):z))
820                 return $ Just i
821     nextI = do
822         i <- gets (head . (\(_,b,_) -> b))
823         modify (\(a,b,c) -> (a, tail b, c))
824         return i
825
826 -- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example
827 -- for @let s = "Ki" in (s, s, cycle "Ho")@:
828 --
829 -- >let x1 = "Ki"
830 -- >    x6 = C# 'H' : C# 'o' : x6
831 -- >in (x1,x1,x6)
832 ppHeapGraph :: HeapGraph -> String
833 ppHeapGraph (HeapGraph m) = letWrapper ++ ppRef 0 (Just heapGraphRoot)
834   where
835     -- All variables occuring more than once
836     bindings = boundMultipleTimes (HeapGraph m) [heapGraphRoot] 
837
838     letWrapper =
839         if null bindings
840         then ""
841         else "let " ++ intercalate "\n    " (map ppBinding bindings) ++ "\nin "
842
843     bindingLetter i = case iToE i of
844         HeapGraphEntry _ c -> case c of 
845             ThunkClosure {..} -> 't'
846             SelectorClosure {..} -> 't'
847             APClosure {..} -> 't'
848             PAPClosure {..} -> 'f'
849             BCOClosure {..} -> 't'
850             FunClosure {..} -> 'f'
851             _ -> 'x'
852
853     ppBindingMap = M.fromList $
854         concat $
855         map (zipWith (\j (i,c) -> (i, [c] ++ show j)) [(1::Int)..]) $
856         groupBy ((==) `on` snd) $ 
857         sortBy (compare `on` snd)
858         [ (i, bindingLetter i) | i <- bindings ]
859
860     ppVar i = ppBindingMap M.! i
861     ppBinding i = ppVar i ++ " = " ++ ppEntry 0 (iToE i)
862
863     ppEntry prec e@(HeapGraphEntry _ c)
864         | Just s <- isString e = show s
865         | Just l <- isList e = "[" ++ intercalate "," (map (ppRef 0) l) ++ "]"
866         | otherwise = ppClosure ppRef prec c
867
868     ppRef _ Nothing = "..."
869     ppRef prec (Just i) | i `elem` bindings = ppVar i
870                         | otherwise = ppEntry prec (iToE i) 
871     iToE i = m M.! i
872
873     iToUnboundE i = if i `elem` bindings then Nothing else M.lookup i m
874
875     isList :: HeapGraphEntry -> Maybe ([Maybe HeapGraphIndex])
876     isList (HeapGraphEntry _ c) = 
877         if isNil c
878           then return []
879           else do
880             (h,t) <- isCons c
881             ti <- t
882             e <- iToUnboundE ti
883             t' <- isList e
884             return $ (:) h t'
885
886     isString :: HeapGraphEntry -> Maybe String
887     isString e = do
888         list <- isList e
889         -- We do not want to print empty lists as "" as we do not know that they
890         -- are really strings.
891         if (null list)
892             then Nothing
893             else mapM (isChar . (\(HeapGraphEntry _ c) -> c) <=< iToUnboundE <=< id) list
894
895
896 -- | In the given HeapMap, list all indices that are used more than once. The
897 -- second parameter adds external references, commonly @[heapGraphRoot]@.
898 boundMultipleTimes :: HeapGraph -> [HeapGraphIndex] -> [HeapGraphIndex]
899 boundMultipleTimes (HeapGraph m) roots = map head $ filter (not.null) $ map tail $ group $ sort $
900      roots ++ concatMap (\(HeapGraphEntry _ c) -> catMaybes (allPtrs c)) (M.elems m)
901
902 -- | An a variant of 'Box' that does not keep the value alive.
903 -- 
904 -- Like 'Box', its 'Show' instance is highly unsafe.
905 newtype WeakBox = WeakBox (Weak Box)
906
907
908 type WeakClosure = GenClosure WeakBox
909
910 instance Show WeakBox where
911     showsPrec p (WeakBox w) rs = case unsafePerformIO (deRefWeak w) of
912         Nothing -> let txt = "(freed)" in
913                    replicate (2*wORD_SIZE - length txt) ' ' ++ txt ++ rs
914         Just b -> showsPrec p b rs
915
916 {-|
917   Turns a 'Box' into a 'WeakBox', allowing the referenced value to be garbage
918   collected.
919 -}
920 weakBox :: Box -> IO WeakBox
921 weakBox b@(Box a) = WeakBox `fmap` mkWeak a b Nothing
922
923 {-|
924   Checks whether the value referenced by a weak box is still alive
925 -}
926 isAlive :: WeakBox -> IO Bool
927 isAlive (WeakBox w) = isJust `fmap` deRefWeak w
928
929 {-|
930   Dereferences the weak box
931 -}
932 derefWeakBox :: WeakBox -> IO (Maybe Box)
933 derefWeakBox (WeakBox w) = deRefWeak w
934
935 weakenClosure :: Closure -> IO WeakClosure
936 weakenClosure = T.mapM weakBox