{-# LANGUAGE BangPatterns, DoAndIfThenElse #-}
module GHC.AssertNF (
assertNF,
assertNFNamed,
assertNFHere,
disableAssertNF,
isNF,
)
where
import GHC.HeapView
import Debug.Trace
import Control.Monad
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 :: IORef Bool
enabledRef = IO (IORef Bool) -> IORef Bool
forall a. IO a -> a
unsafePerformIO (IO (IORef Bool) -> IORef Bool) -> IO (IORef Bool) -> IORef Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
{-# NOINLINE enabledRef #-}
isHNF :: Closure -> IO Bool
isHNF :: Closure -> IO Bool
isHNF Closure
c = do
case Closure
c of
ThunkClosure {} -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
APClosure {} -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
SelectorClosure {} -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
BCOClosure {} -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Closure
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
assertNF :: a -> IO ()
assertNF :: a -> IO ()
assertNF = String -> a -> IO ()
forall a. String -> a -> IO ()
assertNF' String
"Parameter not in normal form"
assertNFNamed :: String -> a -> IO ()
assertNFNamed :: String -> a -> IO ()
assertNFNamed String
valName = String -> a -> IO ()
forall a. String -> a -> IO ()
assertNF' (String
valName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not in normal form")
assertNFHere :: Q Exp
assertNFHere :: Q Exp
assertNFHere = do
String
locStr <- Loc -> String
formatLoc (Loc -> String) -> Q Loc -> Q String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location
Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE (String -> Name
mkName String
"GHC.AssertNF.assertNFNamed"))
(Lit -> Exp
LitE (String -> Lit
StringL String
locStr))
where formatLoc :: Loc -> String
formatLoc :: Loc -> String
formatLoc Loc
loc = let file :: String
file = Loc -> String
loc_filename Loc
loc
(Int
line, Int
col) = Loc -> (Int, Int)
loc_start Loc
loc
in String -> String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"parameter at %s:%d:%d" String
file Int
line Int
col
assertNF' :: String -> a -> IO ()
assertNF' :: String -> a -> IO ()
assertNF' String
str a
x = do
Bool
en <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
enabledRef
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
en (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[Int]
depths <- Int -> Box -> IO [Int]
assertNFBoxed Int
0 (a -> Box
forall a. a -> Box
asBox a
x)
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
depths) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
HeapGraph ()
g <- Int -> () -> Box -> IO (HeapGraph ())
forall a. Monoid a => Int -> a -> Box -> IO (HeapGraph a)
buildHeapGraph ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
depths Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) () (a -> Box
forall a. a -> Box
asBox a
x)
String -> IO ()
traceIO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
depths) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" thunks found:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
HeapGraph () -> String
forall a. HeapGraph a -> String
ppHeapGraph HeapGraph ()
g
assertNFBoxed :: Int -> Box -> IO [Int]
assertNFBoxed :: Int -> Box -> IO [Int]
assertNFBoxed !Int
d Box
b = do
Closure
c <- Box -> IO Closure
getBoxedClosureData Box
b
Bool
nf <- Closure -> IO Bool
isHNF Closure
c
if Bool
nf
then do
Closure
c' <- Box -> IO Closure
getBoxedClosureData Box
b
[[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Int]] -> [Int]) -> IO [[Int]] -> IO [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Box -> IO [Int]) -> [Box] -> IO [[Int]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int -> Box -> IO [Int]
assertNFBoxed (Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) (Closure -> [Box]
forall b. GenClosure b -> [b]
allClosures Closure
c')
else [Int] -> IO [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return [Int
d]
disableAssertNF :: IO ()
disableAssertNF :: IO ()
disableAssertNF = IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
enabledRef Bool
False
isNF :: a -> IO Bool
isNF :: a -> IO Bool
isNF a
x = Box -> IO Bool
isNFBoxed (a -> Box
forall a. a -> Box
asBox a
x)
isNFBoxed :: Box -> IO Bool
isNFBoxed :: Box -> IO Bool
isNFBoxed Box
b = do
Closure
c <- Box -> IO Closure
getBoxedClosureData Box
b
Bool
nf <- Closure -> IO Bool
isHNF Closure
c
if Bool
nf
then do
Closure
c' <- Box -> IO Closure
getBoxedClosureData Box
b
(Box -> IO Bool) -> [Box] -> IO Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM Box -> IO Bool
isNFBoxed (Closure -> [Box]
forall b. GenClosure b -> [b]
allClosures Closure
c')
else Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
allM :: (a -> m Bool) -> [a] -> m Bool
allM a -> m Bool
_ [] = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
allM a -> m Bool
p (a
x:[a]
xs) = do
Bool
q <- a -> m Bool
p a
x
if Bool
q
then (a -> m Bool) -> [a] -> m Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM a -> m Bool
p [a]
xs
else Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False