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