ghc-heap-view 0.4.1.0 → 0.4.2.0

raw patch · 4 files changed

+154/−8 lines, 4 filesdep +template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: template-haskell

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• ghc-heap-view.cabal +6/−3
• src/GHC/AssertNF.hs +123/−0
• src/GHC/HeapView.hs +24/−4

@@ -1,4 +1,4 @@-Copyright (c)2012, Joachim Breitner+Copyright (c) 2012-2013, Joachim Breitner  All rights reserved. 

@@ -1,5 +1,5 @@ Name:                ghc-heap-view-Version:             0.4.1.0+Version:             0.4.2.0 Synopsis:            Extract the heap representation of Haskell values and thunks Description:   This library provides functions to introspect the Haskell heap, for example@@ -42,7 +42,7 @@ License-file:        LICENSE Author:              Joachim Breitner, Dennis Felsing Maintainer:          Joachim Breitner <mail@joachim-breitner.de>-Copyright:           2012 Joachim Breitner+Copyright:           2012-2013 Joachim Breitner Category:            Debug, GHC Build-type:          Custom Cabal-version:       >=1.14@@ -54,12 +54,15 @@     Default: False  Library-  Exposed-modules: GHC.HeapView +  Exposed-modules:+    GHC.HeapView +    GHC.AssertNF    Default-Language:    Haskell2010   Build-depends:     base >= 4.5 && < 4.7,     containers,     transformers,+    template-haskell,     ghc   C-Sources: cbits/HeapView.c cbits/HeapViewPrim.cmm   Hs-source-dirs: src/

@@ -0,0 +1,123 @@+{-# LANGUAGE BangPatterns #-}++{-|+Module      :  GHC.AssertNF+Copyright   :  (c) 2013 Joachim Breitner+License     :  BSD3+Maintainer  :  Joachim Breitner <mail@joachim-breitner.de>++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.++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'.++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.++-}+++module GHC.AssertNF (+    assertNF,+    assertNFNamed,+    assertNFHere,+    disableAssertNF,+    )+where++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+import System.IO.Unsafe ( unsafePerformIO )++enabledRef :: IORef Bool+enabledRef = unsafePerformIO $ newIORef True+{-# NOINLINE enabledRef #-}++-- Everything is in normal form, unless it is a+-- thunks 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 +        APClosure {}       -> return False+        SelectorClosure {} -> return False+        BCOClosure {}      -> return False+        _                  -> return True++-- | The function 'assertNF' checks whether its argument is fully evaluated and+-- deeply evaluated. If this is not the case, a warning is printed to the standard output,+-- giving the number of thunks found and printing the shape of the unevaluated object:+--+-- >> let x = 1 + 2+-- >> let y = (x,x)+-- >> assertNF y+-- >Parameter not in normal form: 2 thunks found:+-- >let t1 = _bco+-- >in (t1,t1)+-- >> x+-- >3+-- >> assertNF y+-- >>+--+assertNF :: a -> IO ()+assertNF = assertNF' "Parameter not in normal form"++-- | In order to better identify the source of error messages from 'assertNF', this variant allows you to include a name that is printed in the output:+--+-- >> assertNFNamed "y" y+-- >y not in normal form: 2 thunks found:+-- >let t1 = _bco+-- >in (t1,t1)+--+assertNFNamed :: String -> a -> IO ()+assertNFNamed valName = assertNF' (valName ++ " not in normal form")++-- | This function, when called as @$assertNFHere@ in a module with @-XTemplateHaskell@ enabled, will cause the current filename and position be included in the error message:+--+-- >Parameter at Test.hs:18:1 not in normal form: 2 thunks found:+-- >let t1 = _bco+-- >in (t1,t1)+--+assertNFHere :: Q Exp+assertNFHere = do+    locStr <- formatLoc <$> location+    -- We don't use ''assertNF here, so that this module can be used on a+    -- compiler that does not support TH.+    return $ AppE (VarE (mkName "GHC.AssertNF.assertNFNamed"))+                  (LitE (StringL locStr))+  where formatLoc :: Loc -> String+        formatLoc loc = let file = loc_filename loc+                            (line, col) = loc_start loc+                        in  printf "parameter at %s:%d:%d" file line col++assertNF' :: String ->  a -> IO ()+assertNF' str x = do+    en <- readIORef enabledRef+    when en $ do +        depths <- assertNFBoxed 0 (asBox x)+        unless (null depths) $ do+            g <- buildHeapGraph (maximum depths + 3) (asBox x)+                -- +3 for good mesure; application don't look good otherwise+            traceIO $ str ++ ": " ++ show (length depths) ++ " thunks found:\n" +++                ppHeapGraph g+++assertNFBoxed :: Int -> Box -> IO [Int]+assertNFBoxed !d b = do+    c <- getBoxedClosureData b+    nf <- isHNF c+    if nf+    then do+        c' <- getBoxedClosureData b+        concat <$> mapM (assertNFBoxed (d+1)) (allPtrs c')+    else do+        return [d]++-- | Invoke this function at the top of your 'main' method to turn every call+-- to 'assertNF' and its variants to noops.+disableAssertNF :: IO ()+disableAssertNF = writeIORef enabledRef False

@@ -64,9 +64,10 @@ import Numeric          ( showHex ) import Data.Char import Data.List-import Data.Maybe       ( isJust, fromJust, catMaybes )+import Data.Maybe       ( isJust, catMaybes ) import System.Mem.Weak import Data.Functor+import Data.Function import Data.Foldable    ( Foldable ) import Data.Traversable ( Traversable ) import qualified Data.Traversable as T@@ -758,6 +759,7 @@ -- | Creates a 'HeapGraph' for the value in the box, but not recursing further -- than the given limit. The initial value has index 'heapGraphRoot'. buildHeapGraph :: Int -> Box -> IO HeapGraph+buildHeapGraph limit _ | limit <= 0 = error "buildHeapGraph: First argument has to be positive" buildHeapGraph limit initialBox = do     let initialState = ([], [0..])     HeapGraph <$> execWriterT (runStateT (add limit initialBox) initialState)@@ -802,17 +804,35 @@         then ""         else "let " ++ intercalate "\n    " (map ppBinding bindings) ++ "\nin " -    ppBinding i = "x" ++ show i ++ " = " ++ ppEntry 0 (iToE i)+    bindingLetter i = case iToE i of+        HeapGraphEntry _ c -> case c of +            ThunkClosure {..} -> 't'+            SelectorClosure {..} -> 't'+            APClosure {..} -> 't'+            PAPClosure {..} -> 'f'+            BCOClosure {..} -> 't'+            FunClosure {..} -> 'f'+            _ -> 'x' +    ppBinbingMap = M.fromList $+        concat $+        map (zipWith (\j (i,c) -> (i, [c] ++ show j)) [(1::Int)..]) $+        groupBy ((==) `on` snd) $ +        sortBy (compare `on` snd)+        [ (i, bindingLetter i) | i <- bindings ]++    ppVar i = ppBinbingMap M.! i+    ppBinding i = ppVar i ++ " = " ++ ppEntry 0 (iToE i)+     ppEntry prec e@(HeapGraphEntry _ c)         | Just s <- isString e = show s         | Just l <- isList e = "[" ++ intercalate "," (map (ppRef 0) l) ++ "]"         | otherwise = ppClosure ppRef prec c      ppRef _ Nothing = "..."-    ppRef prec (Just i) | i `elem` bindings = "x" ++ show i+    ppRef prec (Just i) | i `elem` bindings = ppVar i                         | otherwise = ppEntry prec (iToE i) -    iToE i = fromJust (M.lookup i m)+    iToE i = m M.! i      iToUnboundE i = if i `elem` bindings then Nothing else M.lookup i m