-------------------------------------------------------------------------------

-- So, with the following configuration, -O2 is smart enough
-- to produce the correct Bool output, without seeming to
-- do any work. (But not with -O0 or even with -O.)
--- #define STATS 0
--- #define NO_PERIODIC_BRANCH 1
--- #define STRICT_FIELDS 1
--
-- In fact, -O0, -O and -O2 all have distinct behaviour:
--  -O2 returns the result "instantly"
--  -O returns the result in a second or two
--  -O0 returns only after a long run

-------------------------------------------------------------------------------

  {-# LANGUAGE CPP #-}  -- (or run cpp manually if need be)

-------------------------------------------------------------------------------

-- Whether to run getStats computation (and output status lines).
-- Note that when STATS is 1, this constitutes a forcing factor:
-- Strictness is a bit like QM that way...
#define STATS 1

-- If you explicitly performGC at the start of each getStats, you
-- get a more regular sequence of status lines; but you are also
-- tampering with the natural behaviour of the garbage collector.
#define PERFORM_GC 1

-- This switch is offered because, only when set, is there a
-- difference between -O and -O2 evident.  (-O0 differs in any case.)
-- And only when un-set will this program leak at -O2.
-- (Only applicable when STATS is 0.)
#define NO_PERIODIC_BRANCH 0

-- This leak is not plugged by strict fields!
-- (In the case of STATS 0 and NO_PERIODIC_BRANCH 1, the leak is
-- not manifest with -O2, but this is not due to the strict field.)
#define STRICT_FIELDS 1

-- Superfluous I guess.
#define RECORD_SYNTAX 0

-------------------------------------------------------------------------------

#if STATS
-- XXX This doesn't work!
-- Please GHC-compile with -rtsopts -with-rtsopts=-s -with-rtsopts=-T
-- (-s not -T are independent; nice to see -s summary info.)
  {-# OPTIONS_GHC -rtsopts #-}
  {-  OPTIONS_GHC -with-rtsopts=-s #-}
  {-# OPTIONS_GHC -with-rtsopts=-T #-}
#endif

-------------------------------------------------------------------------------

  import Control.Exception ( evaluate )  -- (\x -> (return $! x) >>= return)

  import GHC.Stats
  import GHC.Int ( Int64 )
  import System.Mem ( performGC )

-------------------------------------------------------------------------------

  duration = 5000000  -- XXX tune for your hardware

  report_period = duration `div` 10
--report_period = 500000  -- GHC 7.8.3 -O2 is two smart (when STATS=0)

-------------------------------------------------------------------------------

#if RECORD_SYNTAX
#if STRICT_FIELDS
  data State = St { st :: !Bool }
#else
  data State = St { st :: Bool }
#endif
#else
#if STRICT_FIELDS
  data State = St !Bool
#else
  data State = St Bool
#endif
#endif

  toggle (St b) = St (not b)

-------------------------------------------------------------------------------

  main = do

    putStrLn "Leaky started."
#if STATS
    putStrLn $ "\n" ++ pad "live heap" ++ "  " ++ pad "just alloc'd"
#endif

    rslt <- duty (St False) 0 0
    evaluate rslt

    putStrLn "\nFinished."

-------------------------------------------------------------------------------

  duty :: State -> Int -> Int64 -> IO State
  duty state i last_total_bytes_allocated = do

#if RECORD_SYNTAX
    let state' = state { st = not (st state) }
#else
    let state' = toggle state
--  let state' = (\(St b)->St (not b)) state
--  let state' = let St b = state in St (not b)
#endif

#if STATS
    new_total_bytes_allocated
     <- if 0 == i `mod` report_period
        then do
#if PERFORM_GC
          performGC
#endif
          stats <- getGCStats
          let bytes = bytesAllocated stats
          putStrLn $    pad (show (currentBytesUsed stats)) ++ "  "
                     ++ pad (show (bytes - last_total_bytes_allocated))
          return $ bytesAllocated stats
        else return last_total_bytes_allocated
#else
    let new_total_bytes_allocated = last_total_bytes_allocated
#if ! NO_PERIODIC_BRANCH
    if 0 == i `mod` report_period
--  if 0 == i `mod` 2  -- GHC 7.8.3 -O2 is two smart
    then do
--    putStrLn "."  -- unnecessary
      return ()
    else return ()
#endif
#endif

    if i < duration
    then duty state' (1+i) new_total_bytes_allocated
    else return state'

-------------------------------------------------------------------------------

  pad :: String -> String
  pad s = (take (15 - length s) $ repeat ' ') ++ s

-------------------------------------------------------------------------------