1 {-# LANGUAGE MagicHash, UnboxedTuples, CPP, ForeignFunctionInterface, GHCForeignImportPrim, UnliftedFFITypes, BangPatterns, RecordWildCards, DeriveFunctor, DeriveFoldable, DeriveTraversable, PatternGuards #-}
4 Copyright : (c) 2012 Joachim Breitner
6 Maintainer : Joachim Breitner <mail@joachim-breitner.de>
8 With this module, you can investigate the heap representation of Haskell
9 values, i.e. to investigate sharing and lazy evaluation.
21 -- * Reading from the heap
55 import GHC.Exts ( Any,
56 Ptr(..), Addr#, Int(..), Word(..), Word#, Int#,
57 ByteArray#, Array#, sizeofByteArray#, sizeofArray#, indexArray#, indexWordArray#,
60 import GHC.Arr (Array(..))
62 import GHC.Constants ( wORD_SIZE, tAG_MASK, wORD_SIZE_IN_BITS )
64 import System.IO.Unsafe ( unsafePerformIO )
66 import Foreign hiding ( unsafePerformIO )
67 import Numeric ( showHex )
70 import Data.Maybe ( isJust, catMaybes )
71 import Data.Monoid ( Monoid, (<>), mempty )
72 import System.Mem.Weak
75 import Data.Foldable ( Foldable )
76 import Data.Traversable ( Traversable )
77 import qualified Data.Traversable as T
78 import qualified Data.IntMap as M
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
85 #include "ghcautoconf.h"
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.
93 #if SIZEOF_VOID_P == 8
94 type HalfWord = Word32
96 type HalfWord = Word16
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
105 ptr = W# (aToWord# a)
106 tag = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
108 -- want 0s prefixed to pad it out to a fixed length.
110 '0':'x':(replicate (2*wORD_SIZE - length ls) '0') ++ ls
112 instance Eq Box where
113 Box a == Box b = case reallyUnsafePtrEqualityUpToTag# a b of
118 This takes an arbitrary value and puts it into a box. Note that calls like
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:
125 > case list of x:_ -> asBox x
128 asBox x = Box (unsafeCoerce# x)
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
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.
142 data StgInfoTable = StgInfoTable {
150 instance Storable StgInfoTable where
157 sizeOf (undefined :: HalfWord),
165 = error "Storable StgInfoTable is read-only"
168 = flip (evalStateT) (castPtr a0)
178 tipe = toEnum (fromIntegral (tipe'::HalfWord)),
182 fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int
183 fieldSz sel x = sizeOf (sel x)
185 load :: Storable a => PtrIO a
186 load = do addr <- advance
189 type PtrIO = StateT (Ptr Word8) IO
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) }
196 sizeOfPointee :: (Storable a) => Ptr a -> Int
197 sizeOfPointee addr = sizeOf (typeHack addr)
198 where typeHack = undefined :: Ptr a -> a
201 Data Type representing Closures
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>
218 | CONSTR_NOCAF_STATIC
257 | MUT_ARR_PTRS_FROZEN0
258 | MUT_ARR_PTRS_FROZEN
271 deriving (Show, Eq, Enum, Ord)
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>
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'
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)
349 -- Card table ignored
366 BlockingQueueClosure {
381 deriving (Show, Functor, Foldable, Traversable)
384 type Closure = GenClosure Box
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 {..}) = []
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#
412 -- Workd-around code until http://hackage.haskell.org/trac/ghc/ticket/5931 was
415 -- foreign import prim "aToWordzh" aToWord'# :: Addr# -> Word#
416 foreign import prim "slurpClosurezh" slurpClosure'# :: Word# -> (# Addr#, ByteArray#, Array# b #)
418 foreign import prim "reallyUnsafePtrEqualityUpToTag" reallyUnsafePtrEqualityUpToTag'# :: Word# -> Word# -> Int#
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
424 aToWord# :: Any -> Word#
425 aToWord# a = case Ptr' a of mb@(Ptr' _) -> case unsafeCoerce# mb :: Word of W# addr -> addr
427 slurpClosure# :: Any -> (# Addr#, ByteArray#, Array# b #)
428 slurpClosure# a = slurpClosure'# (aToWord# a)
430 reallyUnsafePtrEqualityUpToTag# :: Any -> Any -> Int#
431 reallyUnsafePtrEqualityUpToTag# a b = reallyUnsafePtrEqualityUpToTag'# (aToWord# a) (aToWord# b)
435 -- getClosure x >>= print
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])
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)
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
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)
467 b2s :: [Word8] -> String
468 b2s = fmap (chr . fromIntegral)
470 getConDescAddress :: Ptr StgInfoTable -> IO (Ptr Word8)
471 getConDescAddress ptr'
473 offsetToString <- peek (ptr' `plusPtr` (negate wORD_SIZE))
474 return $ (ptr' `plusPtr` stdInfoTableSizeB)
475 `plusPtr` (fromIntegral (offsetToString :: Word))
476 -- This is code for !ghciTablesNextToCode:
478 | otherwise = peek . intPtrToPtr
484 -- hmmmmmm. Is there any way to tell this?
485 opt_SccProfilingOn = False
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
492 = size_fixed + size_prof
494 size_fixed = 2 -- layout, type
495 size_prof | opt_SccProfilingOn = 2
498 stdInfoTableSizeB :: Int
499 stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
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
512 (pkg, rest1) = break (== fromIntegral (ord ':')) input
514 = (concat $ intersperse [dot] $ reverse modWords, occWord)
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])
524 = case break (== dot) str of
525 (top, []) -> (acc, top)
526 (top, _:bot) -> parseModOcc (top : acc) bot
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
533 getClosureData :: a -> IO Closure
534 getClosureData x = do
535 (iptr, wds, ptrs) <- getClosureRaw x
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
542 t | t >= THUNK && t <= THUNK_STATIC -> do
543 return $ ThunkClosure itbl ptrs (drop (length ptrs + 2) wds)
545 t | t >= FUN && t <= FUN_STATIC -> do
546 return $ FunClosure itbl ptrs (drop (length ptrs + 1) wds)
549 return $ APClosure itbl
550 (fromIntegral $ wds !! 2)
551 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
552 (head ptrs) (tail ptrs)
555 return $ PAPClosure itbl
556 (fromIntegral $ wds !! 2)
557 (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2))
558 (head ptrs) (tail ptrs)
561 return $ APStackClosure itbl (head ptrs) (tail ptrs)
564 return $ SelectorClosure itbl (head ptrs)
567 return $ IndClosure itbl (head ptrs)
569 return $ IndClosure itbl (head ptrs)
571 return $ BlackholeClosure itbl (head ptrs)
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))
580 return $ ArrWordsClosure itbl (wds !! 1) (drop 2 wds)
582 t | t == MUT_ARR_PTRS_FROZEN || t == MUT_ARR_PTRS_FROZEN0 ->
583 return $ MutArrClosure itbl (wds !! 1) (wds !! 2) ptrs
585 t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY ->
586 return $ MutVarClosure itbl (head ptrs)
588 t | t == MVAR_CLEAN || t == MVAR_DIRTY ->
589 return $ MVarClosure itbl (ptrs !! 0) (ptrs !! 1) (ptrs !! 2)
592 return $ OtherClosure itbl ptrs wds
593 -- return $ BlockingQueueClosure itbl
594 -- (ptrs !! 0) (ptrs !! 1) (ptrs !! 2) (ptrs !! 3)
596 -- return $ OtherClosure itbl ptrs wds
599 return $ UnsupportedClosure itbl
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
606 isChar :: GenClosure b -> Maybe Char
607 isChar (ConsClosure { name = "C#", dataArgs = [ch], ptrArgs = []}) = Just (chr (fromIntegral ch))
610 isCons :: GenClosure b -> Maybe (b, b)
611 isCons (ConsClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t)
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
623 isNil :: GenClosure b -> Bool
624 isNil (ConsClosure { name = "[]", dataArgs = [], ptrArgs = []}) = True
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'.
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 $
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) $
652 PAPClosure {..} -> app $ map (showBox 10) $
654 APStackClosure {..} -> app $ map (showBox 10) $
656 BCOClosure {..} -> app
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]
667 "_fun" ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs)
668 BlockingQueueClosure {..} ->
672 UnsupportedClosure {..} ->
675 addBraces True t = "(" ++ t ++ ")"
676 addBraces False t = t
679 app xs = addBraces (10 <= prec) (intercalate " " xs)
681 braceize xs = "{" ++ intercalate "," xs ++ "}"
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.
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'.
696 -- | Heap maps as tree, i.e. no sharing, no cycles.
697 data HeapTree = HeapTree WeakBox (GenClosure HeapTree) | EndOfHeapTree
699 heapTreeClosure :: HeapTree -> Maybe (GenClosure HeapTree)
700 heapTreeClosure (HeapTree _ c) = Just c
701 heapTreeClosure EndOfHeapTree = Nothing
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
706 buildHeapTree :: Int -> Box -> IO HeapTree
707 buildHeapTree 0 _ = do
708 return $ EndOfHeapTree
709 buildHeapTree n b = do
711 c <- getBoxedClosureData b
712 c' <- T.mapM (buildHeapTree (n-1)) c
713 return $ HeapTree w c'
715 -- | Pretty-Printing a heap Tree
717 -- Example output for @[Just 4, Nothing, *something*]@, where *something* is an
718 -- unevaluated expression depending on the command line argument.
720 -- >[Just (I# 4),Nothing,Just (_thunk ["arg1","arg2"])]
721 ppHeapTree :: HeapTree -> String
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'
730 isHeapTreeList :: HeapTree -> Maybe ([HeapTree])
731 isHeapTreeList tree = do
732 c <- heapTreeClosure tree
737 t' <- isHeapTreeList t
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.
747 else mapM (isChar <=< heapTreeClosure) list
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'.
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 {
759 hgeClosure :: GenClosure (Maybe HeapGraphIndex),
762 deriving (Show, Functor)
763 type HeapGraphIndex = Int
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))
771 lookupHeapGraph :: HeapGraphIndex -> (HeapGraph a) -> Maybe (HeapGraphEntry a)
772 lookupHeapGraph i (HeapGraph m) = M.lookup i m
774 heapGraphRoot :: HeapGraphIndex
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'.
781 => Int -- ^ Search limit
782 -> a -- ^ Data value for the root
783 -> Box -- ^ The value to start with
785 buildHeapGraph limit rootD initialBox =
786 fst <$> multiBuildHeapGraph limit [(rootD, initialBox)]
788 -- | Creates a 'HeapGraph' for the values in multiple boxes, but not recursing
789 -- further than the given limit.
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.
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)
801 -- | Adds an entry to an existing 'HeapGraph'.
803 -- Returns the updated 'HeapGraph' and the index of the added value.
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)]
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
820 go hge = Just $ hge { hgeData = hgeData hge <> d }
822 generalBuildHeapGraph
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
836 let indices | M.null hg = [0..]
837 | otherwise = [1 + fst (M.findMax hg)..]
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
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
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
855 add 0 _ = return Nothing
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
862 -- Otherwise, allocate a new index
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))
874 i <- gets (head . (\(_,b,_) -> b))
875 modify (\(a,b,c) -> (a, tail b, c))
878 -- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example
879 -- for @let s = \"Ki\" in (s, s, cycle \"Ho\")@:
882 -- > x6 = C# 'H' : C# 'o' : x6
884 ppHeapGraph :: HeapGraph a -> String
885 ppHeapGraph (HeapGraph m) = letWrapper ++ ppRef 0 (Just heapGraphRoot)
887 -- All variables occuring more than once
888 bindings = boundMultipleTimes (HeapGraph m) [heapGraphRoot]
893 else "let " ++ intercalate "\n " (map ppBinding bindings) ++ "\nin "
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'
904 ppBindingMap = M.fromList $
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 ]
911 ppVar i = ppBindingMap M.! i
912 ppBinding i = ppVar i ++ " = " ++ ppEntry 0 (iToE i)
915 | Just s <- isString hge = show s
916 | Just l <- isList hge = "[" ++ intercalate "," (map (ppRef 0) l) ++ "]"
917 | otherwise = ppClosure ppRef prec (hgeClosure hge)
919 ppRef _ Nothing = "..."
920 ppRef prec (Just i) | i `elem` bindings = ppVar i
921 | otherwise = ppEntry prec (iToE i)
924 iToUnboundE i = if i `elem` bindings then Nothing else M.lookup i m
926 isList :: HeapGraphEntry a -> Maybe ([Maybe HeapGraphIndex])
928 if isNil (hgeClosure hge)
931 (h,t) <- isCons (hgeClosure hge)
937 isString :: HeapGraphEntry a -> Maybe String
940 -- We do not want to print empty lists as "" as we do not know that they
941 -- are really strings.
944 else mapM (isChar . hgeClosure <=< iToUnboundE <=< id) list
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)
953 -- | An a variant of 'Box' that does not keep the value alive.
955 -- Like 'Box', its 'Show' instance is highly unsafe.
956 newtype WeakBox = WeakBox (Weak Box)
959 type WeakClosure = GenClosure WeakBox
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
968 Turns a 'Box' into a 'WeakBox', allowing the referenced value to be garbage
971 weakBox :: Box -> IO WeakBox
972 weakBox b@(Box a) = WeakBox `fmap` mkWeak a b Nothing
975 Checks whether the value referenced by a weak box is still alive
977 isAlive :: WeakBox -> IO Bool
978 isAlive (WeakBox w) = isJust `fmap` deRefWeak w
981 Dereferences the weak box
983 derefWeakBox :: WeakBox -> IO (Maybe Box)
984 derefWeakBox (WeakBox w) = deRefWeak w
986 weakenClosure :: Closure -> IO WeakClosure
987 weakenClosure = T.mapM weakBox