diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -2,66 +2,79 @@ import GHC.Exts import GHC.HeapView + import Control.DeepSeq +import Control.Monad import System.Environment import System.Mem -import Control.Monad -l = [1,2,3] - +main :: IO () main = do args <- map length `fmap` getArgs - let l2 = 4:l - (l ++ l2 ++ args) `deepseq` return () + let list2 = 4:list + (list ++ list2 ++ args) `deepseq` pure () - let x = l ++ l2 ++ args + let x = list ++ list2 ++ args performGC - cl <- getClosureData l - case cl of ConsClosure {} -> return () - unless (name cl == ":") $ do - fail "Wrong name" - - cl <- getClosureData l2 - case cl of ConsClosure {} -> return () - eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox l) - unless eq $ do - fail "Doesnt reference l" + getClosureAssert list >>= \ cl -> + unless (name cl == ":") $ fail "Wrong name" - cl <- getClosureData args - unless (tipe (info cl) == CONSTR_NOCAF_STATIC) $ do - fail "Not a CONSTR_NOCAF_STATIC" + getClosureAssert list2 >>= \ cl -> do + eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox list) + unless eq $ fail "Doesn't reference list" - cl <- getClosureData x - unless (tipe (info cl) == THUNK_2_0) $ do - fail "Not a THUNK_2_0" + getClosureData args >>= \ cl -> + assertClosureType CONSTR_NOCAF_STATIC (info cl) + getClosureData x >>= \ cl -> + assertClosureType THUNK_2_0 (info cl) let !(I# m) = length args + 42 let !(I# m') = length args + 23 - let f = \x n -> take (I# m + I# x) n ++ args - t = f m' l2 + let f = \ y n -> take (I# m + I# y) n ++ args + performGC - cl <- getClosureData f - unless (tipe (info cl) == FUN_1_1) $ do - fail "Not a FUN_1_1" - unless (dataArgs cl == [42]) $ do - fail "Wrong data arg" - cl <- getClosureData t - unless (tipe (info cl) == THUNK) $ do - fail "Not a THUNK" - unless (dataArgs cl == [23]) $ do - fail "Wrong data arg" - eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox f) - unless eq $ do - fail "t doesnt reference f" + getClosureData f >>= \ cl -> do + assertClosureType FUN_1_1 (info cl) + unless (dataArgs cl == [42]) $ do + fail "Wrong data arg" - let x = id (:) () x - x `seq` return () + let t = f m' list2 + getClosureData t >>= \ cl -> do + assertClosureType THUNK (info cl) + unless (dataArgs cl == [23]) $ do + fail "Wrong data arg" + + eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox f) + unless eq $ fail "t doesnt reference f" + + let z = id (:) () z + z `seq` pure () performGC + getClosureAssert z >>= \ cl -> do + eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox z) + unless eq $ + fail "z doesnt reference itself" + + putStrLn "Done. No errors." + + +list :: [Int] +list = [1,2,3] + + +getClosureAssert :: a -> IO Closure +getClosureAssert x = do cl <- getClosureData x - case cl of ConsClosure {} -> return () - eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox x) - unless eq $ do - fail "x doesnt reference itself" + case cl of + ConsClosure {} -> pure cl + _ -> fail "Expected ConsClosure" + + +assertClosureType :: ClosureType -> StgInfoTable -> IO () +assertClosureType expected itable = do + let actual = tipe itable + unless (actual == expected) $ + fail $ "Expected " ++ show expected ++ " but got " ++ show actual diff --git a/cbits/HeapView.c b/cbits/HeapView.c --- a/cbits/HeapView.c +++ b/cbits/HeapView.c @@ -57,7 +57,11 @@ [PAP] = "PAP", [AP_STACK] = "AP_STACK", [IND] = "IND", +#ifdef MIN_VERSION_GLASGOW_HASKELL +#if !MIN_VERSION_GLASGOW_HASKELL(8,1,0,0) [IND_PERM] = "IND_PERM", +#endif +#endif [IND_STATIC] = "IND_STATIC", [RET_BCO] = "RET_BCO", [RET_SMALL] = "RET_SMALL", @@ -230,7 +234,11 @@ break; case IND: +#ifdef MIN_VERSION_GLASGOW_HASKELL +#if !MIN_VERSION_GLASGOW_HASKELL(8,1,0,0) case IND_PERM: +#endif +#endif case IND_STATIC: case BLACKHOLE: ptrs[nptrs++] = (StgClosure *)(((StgInd *)closure)->indirectee); diff --git a/ghc-heap-view.cabal b/ghc-heap-view.cabal --- a/ghc-heap-view.cabal +++ b/ghc-heap-view.cabal @@ -1,14 +1,14 @@ Name: ghc-heap-view -Version: 0.5.7 +Version: 0.5.8 Synopsis: Extract the heap representation of Haskell values and thunks Description: This library provides functions to introspect the Haskell heap, for example to investigate sharing and lazy evaluation. As this is tied to the internals - of the compiler,it only works with specific versions. Currently, GHC 7.4 + of the compiler, it only works with specific versions. Currently, GHC 7.4 through 7.10 should be supported. . It has been inspired by (and taken code from) the vacuum package and the GHCi - debugger, but also allows to investiage thunks and other closures. + debugger, but also allows to investigate thunks and other closures. . This package also provides a new GHCi-command, @:printHeap@, which allows you to inspect the current heap representation of a value, including sharing and @@ -94,15 +94,15 @@ if flag(prim-supports-any) cpp-options: -DPRIM_SUPPORTS_ANY - + test-suite Test type: exitcode-stdio-1.0 main-is: Test.hs build-depends: base, ghc-heap-view, deepseq default-language: Haskell2010 - Ghc-options: -O0 + Ghc-options: -Wall -O0 - + source-repository head type: git location: git://git.nomeata.de/ghc-heap-view.git diff --git a/src/GHC/AssertNF.hs b/src/GHC/AssertNF.hs --- a/src/GHC/AssertNF.hs +++ b/src/GHC/AssertNF.hs @@ -6,9 +6,9 @@ License : BSD3 Maintainer : Joachim Breitner -To avoid space leaks and unwanted evaluation behaviour, the programmer might want his data to be fully evaluated at certians positions in the code. This can be enforced, for example, by ample use of "Control.DeepSeq", but this comes at a cost. +To avoid space leaks and unwanted evaluation behaviour, the programmer might want his data to be fully evaluated at certain positions in the code. This can be enforced, for example, by ample use of "Control.DeepSeq", but this comes at a cost. -Experienced users hence use 'Control.DeepSeq.deepseq' only to find out about the existance of space leaks and optimize their code to not create the thunks in the first place, until the code no longer shows better performance with 'deepseq'. +Experienced users hence use 'Control.DeepSeq.deepseq' only to find out about the existence of space leaks and optimize their code to not create the thunks in the first place, until the code no longer shows better performance with 'deepseq'. This module provides an alternative approach: An explicit assertion about the evaluation state. If the programmer expect a certain value to be fully evaluated at a specific point of the program (e.g. before a call to 'writeIORef'), he can state that, and as long as assertions are enabled, this statement will be checked. In the production code the assertions can be disabled, to avoid the run-time cost. @@ -27,7 +27,6 @@ import GHC.HeapView import Debug.Trace import Control.Monad -import Data.Functor import Text.Printf import Language.Haskell.TH (Q, Exp(AppE,VarE,LitE), Lit(StringL), Loc, location, loc_filename, loc_start, mkName) import Data.IORef @@ -38,12 +37,12 @@ {-# NOINLINE enabledRef #-} -- Everything is in normal form, unless it is a --- thunks explicitly marked as such. +-- thunk explicitly marked as such. -- Indirection are also considered to be in HNF isHNF :: Closure -> IO Bool isHNF c = do case c of - ThunkClosure {} -> return False + ThunkClosure {} -> return False APClosure {} -> return False SelectorClosure {} -> return False BCOClosure {} -> return False @@ -98,7 +97,7 @@ assertNF' :: String -> a -> IO () assertNF' str x = do en <- readIORef enabledRef - when en $ do + when en $ do depths <- assertNFBoxed 0 (asBox x) unless (null depths) $ do g <- buildHeapGraph (maximum depths + 3) () (asBox x) diff --git a/src/GHC/Disassembler.hs b/src/GHC/Disassembler.hs --- a/src/GHC/Disassembler.hs +++ b/src/GHC/Disassembler.hs @@ -12,9 +12,7 @@ import Data.Binary.Get import Data.Word import Data.Int -import Data.Monoid import Data.Bits -import Data.Functor import Data.Foldable ( Foldable ) import Data.Traversable ( Traversable ) @@ -237,13 +235,13 @@ return BCIBRK_FUN x -> error $ "Unknown opcode " ++ show x (i :) `fmap` nextInst - + -- | The various byte code instructions that GHCi supports. data BCI box = BCISTKCHECK Word | BCIPUSH_L Word16 - | BCIPUSH_LL Word16 Word16 + | BCIPUSH_LL Word16 Word16 | BCIPUSH_LLL Word16 Word16 Word16 | BCIPUSH_G box | BCIPUSH_ALTS box diff --git a/src/GHC/HeapView.hs b/src/GHC/HeapView.hs --- a/src/GHC/HeapView.hs +++ b/src/GHC/HeapView.hs @@ -57,7 +57,7 @@ import GHC.Arr (Array(..)) -import Foreign hiding ( unsafePerformIO, void ) +import Foreign hiding ( void ) import Numeric ( showHex ) import Data.Char import Data.List @@ -96,14 +96,14 @@ instance Show Box where -- From libraries/base/GHC/Ptr.lhs showsPrec _ (Box a) rs = - -- unsafePerformIO (print "↓" >> pClosure a) `seq` + -- unsafePerformIO (print "↓" >> pClosure a) `seq` pad_out (showHex addr "") ++ (if tag>0 then "/" ++ show tag else "") ++ rs where ptr = W# (aToWord# a) tag = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1) addr = ptr - tag -- want 0s prefixed to pad it out to a fixed length. - pad_out ls = + pad_out ls = '0':'x':(replicate (2*wORD_SIZE - length ls) '0') ++ ls -- | Boxes can be compared, but this is not pure, as different heap objects can, @@ -117,7 +117,7 @@ {-| This takes an arbitrary value and puts it into a box. Note that calls like - > asBox (head list) + > asBox (head list) will put the thunk \"head list\" into the box, /not/ the element at the head of the list. For that, use careful case expressions: @@ -149,7 +149,7 @@ instance Storable StgInfoTable where - sizeOf itbl + sizeOf itbl = sum [ fieldSz ptrs itbl, @@ -158,7 +158,7 @@ fieldSz srtlen itbl ] - alignment _ + alignment _ = wORD_SIZE poke _a0 _itbl @@ -171,15 +171,15 @@ nptrs' <- load tipe' <- load srtlen' <- load - return - StgInfoTable { + return + StgInfoTable { ptrs = ptrs', nptrs = nptrs', tipe = toEnum (fromIntegral (tipe'::HalfWord)), srtlen = srtlen' } -fieldSz :: (Storable a, Storable b) => (a -> b) -> a -> Int +fieldSz :: Storable b => (a -> b) -> a -> Int fieldSz sel x = sizeOf (sel x) load :: Storable a => PtrIO a @@ -273,7 +273,13 @@ | CATCH_RETRY_FRAME | CATCH_STM_FRAME | WHITEHOLE - deriving (Show, Eq, Enum, Ord) +#if defined(GHC_8_0) + | SMALL_MUT_ARR_PTRS_CLEAN + | SMALL_MUT_ARR_PTRS_DIRTY + | SMALL_MUT_ARR_PTRS_FROZEN0 + | SMALL_MUT_ARR_PTRS_FROZEN +#endif + deriving (Show, Eq, Enum, Bounded, Ord) {-| This is the main data type of this module, representing a Haskell value on the heap. This reflects @@ -284,7 +290,7 @@ -} data GenClosure b = ConsClosure { - info :: StgInfoTable + info :: StgInfoTable , ptrArgs :: [b] , dataArgs :: [Word] , pkg :: String @@ -292,47 +298,47 @@ , name :: String } | ThunkClosure { - info :: StgInfoTable + info :: StgInfoTable , ptrArgs :: [b] , dataArgs :: [Word] } | SelectorClosure { - info :: StgInfoTable + info :: StgInfoTable , selectee :: b } | IndClosure { - info :: StgInfoTable + info :: StgInfoTable , indirectee :: b } | BlackholeClosure { - info :: StgInfoTable + info :: StgInfoTable , indirectee :: b } | - -- In GHCi, if Linker.h would allow a reverse looup, we could for exported + -- In GHCi, if Linker.h would allow a reverse lookup, we could for exported -- functions fun actually find the name here. -- At least the other direction works via "lookupSymbol -- base_GHCziBase_zpzp_closure" and yields the same address (up to tags) APClosure { - info :: StgInfoTable + info :: StgInfoTable , arity :: HalfWord , n_args :: HalfWord , fun :: b , payload :: [b] } | PAPClosure { - info :: StgInfoTable + info :: StgInfoTable , arity :: HalfWord , n_args :: HalfWord , fun :: b , payload :: [b] } | APStackClosure { - info :: StgInfoTable + info :: StgInfoTable , fun :: b , payload :: [b] } | BCOClosure { - info :: StgInfoTable + info :: StgInfoTable , instrs :: b , literals :: b , bcoptrs :: b @@ -341,53 +347,53 @@ , bitmap :: Word } | ArrWordsClosure { - info :: StgInfoTable + info :: StgInfoTable , bytes :: Word , arrWords :: [Word] } | MutArrClosure { - info :: StgInfoTable + info :: StgInfoTable , mccPtrs :: Word , mccSize :: Word , mccPayload :: [b] -- Card table ignored } | MutVarClosure { - info :: StgInfoTable + info :: StgInfoTable , var :: b } | MVarClosure { - info :: StgInfoTable + info :: StgInfoTable , queueHead :: b , queueTail :: b , value :: b } | FunClosure { - info :: StgInfoTable + info :: StgInfoTable , ptrArgs :: [b] , dataArgs :: [Word] } | BlockingQueueClosure { - info :: StgInfoTable + info :: StgInfoTable , link :: b , blackHole :: b , owner :: b , queue :: b } | OtherClosure { - info :: StgInfoTable + info :: StgInfoTable , hvalues :: [b] , rawWords :: [Word] } | UnsupportedClosure { - info :: StgInfoTable + info :: StgInfoTable } deriving (Show, Functor, Foldable, Traversable) type Closure = GenClosure Box --- | For generic code, this function returns all referenced closures. +-- | For generic code, this function returns all referenced closures. allPtrs :: GenClosure b -> [b] allPtrs (ConsClosure {..}) = ptrArgs allPtrs (ThunkClosure {..}) = ptrArgs @@ -449,7 +455,7 @@ (# iptr, dat, ptrs #) -> do let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE rawWords = [W# (indexWordArray# dat i) | I# i <- [0.. fromIntegral nelems -1] ] - pelems = I# (sizeofArray# ptrs) + pelems = I# (sizeofArray# ptrs) ptrList = amap' Box $ Array 0 (pelems - 1) pelems ptrs -- This is just for good measure, and seems to be not important. mapM_ evaluate ptrList @@ -483,7 +489,7 @@ offsetToString <- peek (ptr' `plusPtr` (negate wORD_SIZE)) return $ (ptr' `plusPtr` stdInfoTableSizeB) `plusPtr` (fromIntegral (offsetToString :: Word)) - -- This is code for !ghciTablesNextToCode: + -- This is code for !ghciTablesNextToCode: {- | otherwise = peek . intPtrToPtr . (+ fromIntegral @@ -544,7 +550,7 @@ getClosureData x = do (iptr, wds, ptrs) <- getClosureRaw x itbl <- peek iptr - case tipe itbl of + case tipe itbl of t | t >= CONSTR && t <= CONSTR_NOCAF_STATIC -> do (pkg, modl, name) <- dataConInfoPtrToNames iptr if modl == "ByteCodeInstr" && name == "BreakInfo" @@ -562,7 +568,7 @@ fail "Expected at least 1 ptr argument to AP" unless (length wds >= 3) $ fail "Expected at least 3 raw words to AP" - return $ APClosure itbl + return $ APClosure itbl (fromIntegral $ wds !! 2) (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2)) (head ptrs) (tail ptrs) @@ -572,7 +578,7 @@ fail "Expected at least 1 ptr argument to PAP" unless (length wds >= 3) $ fail "Expected at least 3 raw words to AP" - return $ PAPClosure itbl + return $ PAPClosure itbl (fromIntegral $ wds !! 2) (fromIntegral $ shiftR (wds !! 2) (wORD_SIZE_IN_BITS `div` 2)) (head ptrs) (tail ptrs) @@ -697,15 +703,15 @@ ["_bco"] ArrWordsClosure {..} -> app ["toArray", "("++show (length arrWords) ++ " words)", intercalate "," (shorten (map show arrWords)) ] - MutArrClosure {..} -> app + MutArrClosure {..} -> app ["toMutArray", "("++show (length mccPayload) ++ " ptrs)", intercalate "," (shorten (map (showBox 10) mccPayload))] MutVarClosure {..} -> app $ ["_mutVar", (showBox 10) var] MVarClosure {..} -> app $ ["MVar", (showBox 10) value] - FunClosure {..} -> + FunClosure {..} -> "_fun" ++ braceize (map (showBox 0) ptrArgs ++ map show dataArgs) - BlockingQueueClosure {..} -> + BlockingQueueClosure {..} -> "_blockingQueue" OtherClosure {..} -> "_other" @@ -716,7 +722,7 @@ app xs = addBraces (10 <= prec) (intercalate " " xs) shorten xs = if length xs > 20 then take 20 xs ++ ["(and more)"] else xs - + {- $heapmap For more global views of the heap, you can use heap maps. These come in @@ -726,7 +732,7 @@ The entries of a 'HeapGraph' can be annotated with arbitrary values. Most operations expect this to be in the 'Monoid' class: They use 'mempty' to annotate closures added because the passed values reference them, and they - use 'mappend' to combine the annotations when two values conincide, e.g. + use 'mappend' to combine the annotations when two values conincide, e.g. during 'updateHeapGraph'. -} @@ -749,7 +755,7 @@ return $ HeapTree b c' -- | Pretty-Printing a heap Tree --- +-- -- Example output for @[Just 4, Nothing, *something*]@, where *something* is an -- unevaluated expression depending on the command line argument. -- @@ -764,7 +770,7 @@ | Just bc <- disassembleBCO heapTreeClosure c' = app ("_bco" : map (go 10) (concatMap F.toList bc)) | otherwise = ppClosure go prec c' - where + where app [a] = a ++ "()" app xs = addBraces (10 <= prec) (intercalate " " xs) @@ -793,7 +799,7 @@ -- exceeding the recursion bound passed to 'buildHeapGraph'. -- -- Besides a pointer to the stored value and the closure representation we --- also keep track of whether the value was still alive at the last update of the +-- also keep track of whether the value was still alive at the last update of the -- heap graph. In addition we have a slot for arbitrary data, for the user's convenience. data HeapGraphEntry a = HeapGraphEntry { hgeBox :: Box, @@ -843,7 +849,7 @@ -- -- Returns the updated 'HeapGraph' and the index of the added value. addHeapGraph - :: Monoid a + :: Monoid a => Int -- ^ Search limit -> a -- ^ Data to be stored with the added value -> Box -- ^ Value to add to the graph @@ -860,7 +866,7 @@ where go hge = Just $ hge { hgeData = hgeData hge <> d } -generalBuildHeapGraph +generalBuildHeapGraph :: Monoid a => Int -> HeapGraph a @@ -872,7 +878,7 @@ let boxList = [ (hgeBox hge, i) | (i, hge) <- M.toList hg ] indices | M.null hg = [0..] | otherwise = [1 + fst (M.findMax hg)..] - + initialState = (boxList, indices, []) -- It is ok to use the Monoid (IntMap a) instance here, because -- we will, besides the first time, use 'tell' only to add singletons not @@ -931,7 +937,7 @@ (j, hg') <- liftIO $ addHeapGraph limit (hgeData hge) (hgeBox hge) hg tell (M.singleton i j) return hg' - + -- | Pretty-prints a HeapGraph. The resulting string contains newlines. Example -- for @let s = \"Ki\" in (s, s, cycle \"Ho\")@: -- @@ -942,7 +948,7 @@ ppHeapGraph (HeapGraph m) = letWrapper ++ ppRef 0 (Just heapGraphRoot) where -- All variables occuring more than once - bindings = boundMultipleTimes (HeapGraph m) [heapGraphRoot] + bindings = boundMultipleTimes (HeapGraph m) [heapGraphRoot] letWrapper = if null bindings @@ -961,7 +967,7 @@ ppBindingMap = M.fromList $ concat $ map (zipWith (\j (i,c) -> (i, [c] ++ show j)) [(1::Int)..]) $ - groupBy ((==) `on` snd) $ + groupBy ((==) `on` snd) $ sortBy (compare `on` snd) [ (i, bindingLetter i) | i <- bindings ] @@ -980,13 +986,13 @@ ppRef _ Nothing = "..." ppRef prec (Just i) | i `elem` bindings = ppVar i - | otherwise = ppEntry prec (iToE i) + | otherwise = ppEntry prec (iToE i) iToE i = m M.! i iToUnboundE i = if i `elem` bindings then Nothing else M.lookup i m isList :: HeapGraphEntry a -> Maybe ([Maybe HeapGraphIndex]) - isList hge = + isList hge = if isNil (hgeClosure hge) then return [] else do diff --git a/src/GHC/HeapView/Debug.hs b/src/GHC/HeapView/Debug.hs --- a/src/GHC/HeapView/Debug.hs +++ b/src/GHC/HeapView/Debug.hs @@ -7,17 +7,16 @@ import Control.Monad import System.Mem import Data.Maybe -import Data.Functor import Data.Char import Data.IORef --- | This functions walks the heap referenced by the argument, printing the +-- | This function walks the heap referenced by the argument, printing the -- \"path\", i.e. the pointer indices from the initial to the current closure -- and the closure itself. When the runtime crashes, the problem is likely -- related to one of the earlier steps. walkHeap - :: Bool -- ^ Whether to check for cycles - -> Bool -- ^ Whethter to GC in every step + :: Bool -- ^ Whether to check for cycles + -> Bool -- ^ Whether to GC in every step -> Box -- ^ The closure to investigate -> IO () walkHeap slow check x = do @@ -58,7 +57,7 @@ isCharCons :: GenClosure Box -> IO Bool isCharCons c | Just (h,_) <- isCons c = (isJust . isChar) <$> getBoxedClosureData h -isCharCons _ = return False +isCharCons _ = return False isCons :: GenClosure b -> Maybe (b, b) isCons (ConsClosure { name = ":", dataArgs = [], ptrArgs = [h,t]}) = Just (h,t)