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