src/GHC/AssertNF.hs

   1 {-# LANGUAGE BangPatterns, DoAndIfThenElse #-}
   2
   3 {-|
   4 Module      :  GHC.AssertNF
   5 Copyright   :  (c) 2013 Joachim Breitner
   6 License     :  BSD3
   7 Maintainer  :  Joachim Breitner <mail@joachim-breitner.de>
   8
   9 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.
  10
  11 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'.
  12
  13 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.
  14
  15 -}
  16
  17
  18 module GHC.AssertNF (
  19     assertNF,
  20     assertNFNamed,
  21     assertNFHere,
  22     disableAssertNF,
  23     isNF,
  24     )
  25 where
  26
  27 import GHC.HeapView
  28 import Debug.Trace
  29 import Control.Monad
  30 import Data.Functor
  31 import Text.Printf
  32 import Language.Haskell.TH (Q, Exp(AppE,VarE,LitE), Lit(StringL), Loc, location, loc_filename, loc_start, mkName)
  33 import Data.IORef
  34 import System.IO.Unsafe ( unsafePerformIO )
  35
  36 enabledRef :: IORef Bool
  37 enabledRef = unsafePerformIO $ newIORef True
  38 {-# NOINLINE enabledRef #-}
  39
  40 -- Everything is in normal form, unless it is a
  41 -- thunks explicitly marked as such.
  42 -- Indirection are also considered to be in HNF
  43 isHNF :: Closure -> IO Bool
  44 isHNF c = do
  45     case c of
  46         ThunkClosure {}    -> return False
  47         APClosure {}       -> return False
  48         SelectorClosure {} -> return False
  49         BCOClosure {}      -> return False
  50         _                  -> return True
  51
  52 -- | The function 'assertNF' checks whether its argument is fully evaluated and
  53 -- deeply evaluated. If this is not the case, a warning is printed to the standard output,
  54 -- giving the number of thunks found and printing the shape of the unevaluated object:
  55 --
  56 -- >> let x = 1 + 2
  57 -- >> let y = (x,x)
  58 -- >> assertNF y
  59 -- >Parameter not in normal form: 2 thunks found:
  60 -- >let t1 = _bco
  61 -- >in (t1,t1)
  62 -- >> x
  63 -- >3
  64 -- >> assertNF y
  65 -- >>
  66 --
  67 assertNF :: a -> IO ()
  68 assertNF = assertNF' "Parameter not in normal form"
  69
  70 -- | 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:
  71 --
  72 -- >> assertNFNamed "y" y
  73 -- >y not in normal form: 2 thunks found:
  74 -- >let t1 = _bco
  75 -- >in (t1,t1)
  76 --
  77 assertNFNamed :: String -> a -> IO ()
  78 assertNFNamed valName = assertNF' (valName ++ " not in normal form")
  79
  80 -- | 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:
  81 --
  82 -- >Parameter at Test.hs:18:1 not in normal form: 2 thunks found:
  83 -- >let t1 = _bco
  84 -- >in (t1,t1)
  85 --
  86 assertNFHere :: Q Exp
  87 assertNFHere = do
  88     locStr <- formatLoc <$> location
  89     -- We don't use ''assertNF here, so that this module can be used on a
  90     -- compiler that does not support TH.
  91     return $ AppE (VarE (mkName "GHC.AssertNF.assertNFNamed"))
  92                   (LitE (StringL locStr))
  93   where formatLoc :: Loc -> String
  94         formatLoc loc = let file = loc_filename loc
  95                             (line, col) = loc_start loc
  96                         in  printf "parameter at %s:%d:%d" file line col
  97
  98 assertNF' :: String ->  a -> IO ()
  99 assertNF' str x = do
 100     en <- readIORef enabledRef
 101     when en $ do
 102         depths <- assertNFBoxed 0 (asBox x)
 103         unless (null depths) $ do
 104             g <- buildHeapGraph (maximum depths + 3) () (asBox x)
 105                 -- +3 for good mesure; applications don't look good otherwise
 106             traceIO $ str ++ ": " ++ show (length depths) ++ " thunks found:\n" ++
 107                 ppHeapGraph g
 108
 109
 110 assertNFBoxed :: Int -> Box -> IO [Int]
 111 assertNFBoxed !d b = do
 112     c <- getBoxedClosureData b
 113     nf <- isHNF c
 114     if nf
 115     then do
 116         c' <- getBoxedClosureData b
 117         concat <$> mapM (assertNFBoxed (d+1)) (allPtrs c')
 118     else do
 119         return [d]
 120
 121 -- | Invoke this function at the top of your 'main' method to turn every call
 122 -- to 'assertNF' and its variants to noops.
 123 disableAssertNF :: IO ()
 124 disableAssertNF = writeIORef enabledRef False
 125
 126 -- | A variant of 'assertNF' that does not print anything and just returns
 127 -- 'True' if the value is in normal form, or 'False' otherwise. This function
 128 -- is not affected by 'disableAssertNF'.
 129 isNF :: a -> IO Bool
 130 isNF x = isNFBoxed (asBox x)
 131
 132 isNFBoxed :: Box -> IO Bool
 133 isNFBoxed b = do
 134     c <- getBoxedClosureData b
 135     nf <- isHNF c
 136     if nf
 137     then do
 138         c' <- getBoxedClosureData b
 139         allM isNFBoxed (allPtrs c')
 140     else do
 141         return False
 142
 143 -- From Control.Monad.Loops in monad-loops, but I'd like to avoid too many
 144 -- trivial dependencies
 145 allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
 146 allM _ []       = return True
 147 allM p (x:xs)   = do
 148         q <- p x
 149         if q
 150                 then allM p xs
 151                 else return False