{-# 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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ 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 {} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
APClosure {} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
SelectorClosure {} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
BCOClosure {} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Closure
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
assertNF :: a -> IO ()
assertNF :: forall a. a -> IO ()
assertNF = forall a. String -> a -> IO ()
assertNF' String
"Parameter not in normal form"
assertNFNamed :: String -> a -> IO ()
assertNFNamed :: forall a. String -> a -> IO ()
assertNFNamed String
valName = forall a. String -> a -> IO ()
assertNF' (String
valName forall a. [a] -> [a] -> [a]
++ String
" not in normal form")
assertNFHere :: Q Exp
assertNFHere :: Q Exp
assertNFHere = do
String
locStr <- Loc -> String
formatLoc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location
forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall r. PrintfType r => String -> r
printf String
"parameter at %s:%d:%d" String
file Int
line Int
col
assertNF' :: String -> a -> IO ()
assertNF' :: forall a. String -> a -> IO ()
assertNF' String
str a
x = do
Bool
en <- forall a. IORef a -> IO a
readIORef IORef Bool
enabledRef
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
en forall a b. (a -> b) -> a -> b
$ do
[Int]
depths <- Int -> Box -> IO [Int]
assertNFBoxed Int
0 (forall a. a -> Box
asBox a
x)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
depths) forall a b. (a -> b) -> a -> b
$ do
HeapGraph ()
g <- forall a. Monoid a => Int -> a -> Box -> IO (HeapGraph a)
buildHeapGraph (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
depths forall a. Num a => a -> a -> a
+ Int
3) () (forall a. a -> Box
asBox a
x)
String -> IO ()
traceIO forall a b. (a -> b) -> a -> b
$ String
str forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
depths) forall a. [a] -> [a] -> [a]
++ String
" thunks found:\n" forall a. [a] -> [a] -> [a]
++
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
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int -> Box -> IO [Int]
assertNFBoxed (Int
dforall a. Num a => a -> a -> a
+Int
1)) (forall b. GenClosure b -> [b]
allClosures Closure
c')
else forall (m :: * -> *) a. Monad m => a -> m a
return [Int
d]
disableAssertNF :: IO ()
disableAssertNF :: IO ()
disableAssertNF = forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
enabledRef Bool
False
isNF :: a -> IO Bool
isNF :: forall a. a -> IO Bool
isNF a
x = Box -> IO Bool
isNFBoxed (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
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM Box -> IO Bool
isNFBoxed (forall b. GenClosure b -> [b]
allClosures Closure
c')
else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
allM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
allM :: forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM a -> 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 forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM a -> m Bool
p [a]
xs
else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False