{-# LANGUAGE DoAndIfThenElse #-}

{-|
Module      :  Cardano.Prelude.GHC.Heap.NormalForm
Copyright   :  (c) 2013 Joachim Breitner
License     :  BSD3

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'.

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.

Copyright (c) 2012-2013, Joachim Breitner

All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of Joachim Breitner nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

-}

module Cardano.Prelude.GHC.Heap.NormalForm
  ( isHeadNormalForm
  , isNormalForm
  )
where

import Cardano.Prelude.Base

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: 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, but I'd like to avoid too many
-- trivial dependencies
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