-- |
-- Module      : GHC.Heap.NormalForm
-- Copyright   : [2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
-- https://github.com/input-output-hk/cardano-prelude/blob/96e8dcb29dc3c29eee99c0d020152fad6071af6d/src/Cardano/Prelude/GHC/Heap/NormalForm.hs
--
-- This code has been adapted from the module "GHC.AssertNF" of the package
-- <http://hackage.haskell.org/package/ghc-heap-view ghc-heap-view>
-- (<https://github.com/nomeata/ghc-heap-view GitHub>) authored by
-- Joachim Breitner.
--
-- 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 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'.
--

module GHC.Heap.NormalForm (

  isHeadNormalForm,
  isNormalForm,

) where

import GHC.Exts.Heap

-- Everything is in normal form, unless it is a thunk explicitly marked as
-- such. Indirection are also considered to be in HNF.
--
isHeadNormalForm :: Closure -> IO Bool
isHeadNormalForm :: Closure -> IO Bool
isHeadNormalForm 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

-- | The function 'isNormalForm' checks whether its argument is fully evaluated
-- and deeply evaluated.
--
-- NOTE 1: If you want to override the behaviour of 'isNormalForm' for specific
-- types (in particular, for specific types that may be /nested/ somewhere
-- inside the @a@), consider using
-- 'Cardano.Prelude.GHC.Heap.NormalForm.Classy.noUnexpectedThunks' instead.
--
-- NOTE 2: The normal form check can be quite brittle, especially with @-O0@.
-- For example, writing something like
--
-- > let !(Value x) = ... in ....
--
-- might translate to
--
-- > let !.. = ... in ... (case ... of Value x -> x)
--
-- which would trivially be @False@. In general, 'isNormalForm' should probably
-- only be used with @-O1@, but even then the answer may still depend on
-- internal decisions made by ghc during compilation.
--
isNormalForm :: a -> IO Bool
isNormalForm :: a -> IO Bool
isNormalForm a
x = Box -> IO Bool
isNormalFormBoxed (a -> Box
forall a. a -> Box
asBox a
x)

isNormalFormBoxed :: Box -> IO Bool
isNormalFormBoxed :: Box -> IO Bool
isNormalFormBoxed Box
b = do
  Closure
c  <- Box -> IO Closure
getBoxedClosureData Box
b
  Bool
nf <- Closure -> IO Bool
isHeadNormalForm 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
isNormalFormBoxed (Closure -> [Box]
forall b. GenClosure b -> [b]
allClosures Closure
c')
    else do
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- From Control.Monad.Loops in monad-loops
--
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