leaky-0.2.0.0: leaky-full-incl-types.hs
-------------------------------------------------------------------------------
-- INSTRUCTIONS
--
-- This example concerns "steady-state" programs, where there
-- is a loop behaviour, and we want to sustain it indefinitely
-- with bounded (constant) space (and ca. constant frame period).
-- Servers and games are two exmaples of applications which fall
-- in this category.
--
-- Adjust duration to suit your hardware.
--
-- Toggle USE_GROWING_LIST and USE_INFINITE_LIST (see comments
-- at the #define's).
--
-- Set FORCING_STRATEGY:
-- 0 = None
-- 1 = Use the usual rnf from Control.DeepSeq
-- 2 = Use rnfn from Control.DeepSeq.Bounded
-- 3 = Use rnfp from Control.DeepSeq.Bounded
-- 4 = Test manual instrumentation with Seqaid.Runtime.seqaid
-- 5 = Test seqaid blanket auto-instrumentation of top-level RHSs
-- 6 = Test seqaid blanket auto-instrumentation at requested type
--
-- Suppose USE_GROWING_LIST=0, and suppose USE_INFINITE_LIST=1
-- (except where stated otherwise). This represents the
-- most "stressful" conditions.
--
-- You should be able to observe that FORCING_STRATEGY = ...
--
-- ... 0 : Has a space leak.
--
-- ... 1 : If USE_INFINITE_LIST, nonterminates; otherwise, has no leak
-- but runs very slowly.
--
-- ... 2 : Has no leak and runs fairly quickly, unless USE_STRICT_BLOB=1.
--
-- ... 3 : Has no leak and, while rnfp is slower than rnfn, it is
-- in the same ballpark (i.e. much faster than the usual rnf).
-- Morever, it gives us fine-grained control that rnfn cannot,
-- and is much faster than rnfn when USE_STRICT_BLOB=1.
--
-- ... 4 :
--
-- ... 5 :
--
-- ... 6 :
--
-- (Mainly tested with GHC 7.8.3 with -O2. -O2 was preferred b/c it
-- represents the most difficult case, where we're definitely
-- seeing these relative performance characteristics, even after
-- GHC has thrown everything it has at this bit of code in the
-- way of optimisations.)
-------------------------------------------------------------------------------
{- OPTIONS_GHC -O2 #-}
{-# OPTIONS_GHC -O0 #-}
-- How frustrating! It's been quite hard to induce this leak with
-- default optimisations in GHC 7.6.3, harder with 7.8.3, and
-- really hard with -O2 and 7.8.3. (But finally got there!)
--
-- And if go -O0, then even simplest recursion with
-- ctor applications leaks! (And "force" doesn't plug it.)
--
-- This scenario is however the classic justification for the
-- relatively lauded strict fields (actually part of Haskell98).
-- Have strict fields been unnecessary since 7.6.3, with default
-- optimisation? I don't think so...
--
-- What is going on "exactly"?...
-------------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
#define DBG 0
#if 0
#ifndef FORCING_STRATEGY
#warning UNDEF
#else
#if FORCING_STRATEGY == 0
#warning 0
#elif FORCING_STRATEGY == 1
#warning 1
#elif FORCING_STRATEGY == 2
#warning 2
#elif FORCING_STRATEGY == 3
#warning 3
#elif FORCING_STRATEGY == 4
#warning 4
#elif FORCING_STRATEGY == 5
#warning 5
#elif FORCING_STRATEGY == 6
#warning 6
#endif
#endif
#endif
-- XXX Sorry! It seems that TH doesn't see a consistent state
-- of CPP macros set by the .cabal flags. For the case that
-- FORCING_STRATEGY is undefined, this must be a TH run, and
-- in that case it's safest to force it to 5...
-- I've not been able to get a definite picture of how CPP,
-- TH, and pragmas interact, but it's not always ideal.
#ifndef FORCING_STRATEGY
#define FORCING_STRATEGY 5
#endif
-- XXX Note that GHC.Stats requires runtime option +RTS -T -RTS to use!
#if FORCING_STRATEGY >= 4
-- (In these cases, seqaid auto-instrumentation generates the output.)
#ifdef STATS
#undef STATS
#endif
#define STATS 0
#else
#endif
#if 0
#if FORCING_STRATEGY == 6
#warning FORCING_STRATEGY 6 not yet working. (Use 5 instead.)
#endif
#endif
-- -- The problem with using a growing list is, it itself is
-- -- a leak (as it were), so it's hard to see you've plugged
-- -- anything. However, the slowdown of "force" relative to "forcep"
-- -- will be noticed!
-- -- Alternative to GROWING is FIXED (is at length 10000 at the moment).
-- -- Fixed list is infinite if INFINITE set below.
-- -- (INFINITE has no effect when GROWING set.)
-- #define USE_GROWING_LIST 1
-- -- XXX For some reason, memory is being retained with REDUCTION.
-- #define USE_GROWING_LIST_REDUCTION 1
-- #define USE_INFINITE_LIST 0
--
-- -- Put some weighty strict subtrees in the test data structure,
-- -- so can showcase forcep's specificity relative to forcen.
-- #define USE_STRICT_BLOB 1
--
-- -- 0 = None
-- -- 1 = Use rnf (the standard Control.DeepSeq)
-- -- 2 = Use rnfn (from Control.DeepSeq.Bounded)
-- -- 3 = Use rnfp (from Control.DeepSeq.Bounded)
-- -- 4 = Test manual instrumentation with Seqaid.Runtime.seqaid
-- -- 5 = Test seqaid blanket auto-instrumentation of top-level RHSs
-- -- 6 = Test seqaid blanket auto-instrumentation at requested type
-- #define FORCING_STRATEGY 6
-------------------------------------------------------------------------------
-- For NFDataP (which perforce includes NFDataN and NFData):
{-# LANGUAGE TemplateHaskell #-}
{- LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{- LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-} -- for GHC 7.6.3
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
-------------------------------------------------------------------------------
-- RankNTypes wanted since some injected type signatures,
-- due to imported types, may require it.
-- The user currently has to add this themselves; it would
-- be nice if SOME available form of automatic injection
-- could do this! (A text-based pre-processor might be able...).
-- (So far as I know, no Haskell library or GHC feature will
-- allow auto-injection of pragmas, but it's quite trivial
-- as a text pre-process.)
{-# LANGUAGE RankNTypes #-}
-------------------------------------------------------------------------------
-- XXX Unfortunately, the way seqaidpp works, a module declaration
-- is mandatory. This won't normally be a big deal, as Main is
-- the only module that is allowed to omit the declaration, and
-- when omitted, it's always equivalent to the following:
module Main ( main ) where
-------------------------------------------------------------------------------
import Control.DeepSeq.Bounded
import Control.DeepSeq.Generics
import Generics.SOP.TH
import GHC.Generics ( Generic )
import Data.Typeable ( Typeable )
import Data.Data ( Data )
--import Control.Concurrent ( threadDelay )
import Control.Monad ( when )
import Control.Exception ( evaluate ) -- (\x -> (return $! x) >>= return)
import System.Environment ( getArgs )
import System.IO ( stdout, hFlush )
import System.Random
import Data.List ( foldl' )
import Debug.Trace ( trace )
-- We synthesize it.
#if 0 && FORCING_STRATEGY == 4
import Seqaid.Runtime ( seqaid )
#endif
-- Now seeing if can inject with seqaidpp...
-- It's not foolproof yet: What if the module
-- has no imports? What if the topmost import
-- is within a block comment???.....
#if ! TEST_SEQAIDPP
#if FORCING_STRATEGY >= 4
import Seqaid.TH
--import Seqaid.Runtime -- comes in with Seqaid.TH
--import Seqaid.Ann -- comes in with Seqaid.TH
#endif
#endif
--import Temp
#if STATS
import GHC.Stats -- requires runtime option +RTS -T -RTS to use!
import GHC.Int ( Int64 )
#endif
-------------------------------------------------------------------------------
#if FORCING_STRATEGY >= 4
{- ANN module (SeqaidAnnExclude "bigStrictBlob") #-} -- works
{- ANN module (SeqaidAnnExclude "main") #-} -- works
{- ANN module (SeqaidAnnExclude "duration") #-} -- fails
{- ANN module (SeqaidAnnExclude "initState") #-} -- fails
-- Those that fail, also fail if give them
-- Oh I see: I ended up "reserving" List one for internal use. [?]
-- But should give an appropriate error when seen in user code then!
{- ANN module (SeqaidAnnExcludeList ["bigStrictBlob","main"]) #-}
#endif
-------------------------------------------------------------------------------
-- XXX Now using GHC -F preprocessor instead.
#if 0 && FORCING_STRATEGY == 4
seqaidManTH
#endif
-------------------------------------------------------------------------------
#if 1
#if FORCING_STRATEGY >= 4
{-# NOINLINE test_auto_ann #-}
#if 1
{- ANN module (SeqaidAnnExclude "test_auto_ann") #-}
test_auto_ann :: a
test_auto_ann = undefined
#else
{- ANN module (SeqaidAnnExclude "test_auto_ann") #-}
test_auto_ann :: NFDataP a => a
test_auto_ann = seqaidDispatch (23,"") $ undefined
#endif
#endif
#endif
-------------------------------------------------------------------------------
#if DBG
duration = 8
--duration = 4
#else
-- XXX tune for your hardware
--duration = 50000
duration = 130000
--duration = 200000
--duration = 500000
--duration = 5000000
#endif
report_period = duration `div` 20
-------------------------------------------------------------------------------
type State = TA
doWork :: Num a => Blob a -> a
doWork (Blob lst) = foldl' (+) 0 lst
data Blob a = Blob [a]
deriving (Show,Generic,Typeable,Data)
instance (NFData a,Num a) => NFData (Blob a) where rnf x = force (doWork x) `seq` ()
instance (NFData a,Num a) => NFDataN (Blob a) where rnfn n x = force (doWork x) `seq` ()
instance (NFData a,Num a,Typeable a) => NFDataP (Blob a) where rnfp p x = force (doWork x) `seq` ()
#if 1
-- (No strict fields.)
data TA = A1 Int | A2 TB Int TC
data TB = B1 | B2 TC | B3 Int TA TB
#if USE_STRICT_BLOB
-- Note: I think Blob must NOT have a strictness bang (!).
-- Later: I doubt it matters, the way doing Blob's now...
data TC = C1 Int TC | C2 Int | C3 TC (Blob Int) ![Int] TC
#else
data TC = C1 Int TC | C2 Int | C3 TC ![Int] TC
#endif
#else
-- All Int fields strict (!):
data TA = A1 !Int | A2 TB !Int TC
data TB = B1 | B2 TC | B3 !Int TA TB
#if USE_STRICT_BLOB
-- Note: I think Blob must NOT have a strictness bang (!).
-- Later: I doubt it matters, the way doing Blob's now...
data TC = C1 !Int TC | C2 !Int | C3 TC (Blob Int) ![Int] TC
#else
data TC = C1 !Int TC | C2 !Int | C3 TC ![Int] TC
#endif
#endif
deriving instance Show TA
deriving instance Generic TA
deriving instance Typeable TA
deriving instance Data TA
deriving instance Show TB
deriving instance Generic TB
deriving instance Typeable TB
deriving instance Data TB
deriving instance Show TC
deriving instance Generic TC
deriving instance Typeable TC
deriving instance Data TC
instance NFDataP TA where rnfp = grnfp
instance NFDataN TA where rnfn = grnfn
instance NFData TA where rnf = genericRnf
instance NFDataP TB where rnfp = grnfp
instance NFDataN TB where rnfn = grnfn
instance NFData TB where rnf = genericRnf
instance NFDataP TC where rnfp = grnfp
instance NFDataN TC where rnfn = grnfn
instance NFData TC where rnf = genericRnf
#if 1
deriveGeneric ''TA
deriveGeneric ''TB
deriveGeneric ''TC
#endif
-------------------------------------------------------------------------------
#if FORCING_STRATEGY >= 4
{-# ANN module (SeqaidAnnExclude "main") #-}
#endif
main :: IO ()
main = do
putStrLn "Started leaky..."
#if STATS
putStrLn $ pad 15 "live heap" ++ pad 15 "total bytes"
#endif
[saltstr] <- getArgs
let salt = read saltstr :: Int
let g = mkStdGen salt
let state = initState
-- Set up the Pattern.
-- (Only referenced when FORCING_STRATEGY=3.)
#if FORCING_STRATEGY == 3
#if USE_STRICT_BLOB
#if 1
let pat | deepseq_bounded_flag__new_improved_pattern_grammar
= compilePat "((!(!)(((!).!(!))))!(!(!)))"
| otherwise
= compilePat "!(!(!!(!)!(!(!(!).!!(!))))!!(!!(!)))"
--- = compilePat "!(!(!!(!)!(!(!(!)!!!(!))))!!(!!(!)))"
#else
#if NEW_IMPROVED_PATTERN_GRAMMAR
let pat = compilePat "((!(!)(((!).!(!))))!(!(!)))"
#else
let pat = compilePat "!(!(!!(!)!(!(!(!).!!(!))))!!(!!(!)))"
-- let pat = compilePat "!(!(!!(!)!(!(!(!)!!!(!))))!!(!!(!)))"
#endif
#endif
#else
let pat = mkPat state -- identical to the explicit pattern below
#endif
putStrLn $ showPat pat
#else
let pat = emptyPat
#endif
#if USE_GROWING_LIST
let state' = state
#else
-- Now that we used "mkPat state" to get the shape of interest,
-- fill in one or more heavy data branches.
#if USE_INFINITE_LIST
let state' = setList [1,2..] state -- bwahaha!!
#else
let state' = setList (take 10000 [1,2..]) state
#endif
#endif
#if STATS
rslt <- duty g pat state' 0 0
evaluate rslt -- force the head
#else
#if 0
#elif 0
rslt <- return $! duty g pat state' 0 -- force the head?
#elif 0
duty g pat state' 0 `seq` return () -- force the head?
#elif 0
evaluate $ duty g pat state' 0 -- force the head?
#elif 0
rslt <- duty g pat state' 0
rslt `seq` return () -- force the head?
#elif 1
rslt <- duty g pat state' 0
evaluate rslt -- force the head!
-- evaluate = \x -> (return $! x) >>= return
#endif
#endif
#if DBG
putStrLn "Finished."
#else
putStrLn "\nFinished."
#endif
-------------------------------------------------------------------------------
#if FORCING_STRATEGY == 4
{-# ANN module (SeqaidAnnManual "duty") #-}
#endif
#if 1
--- #if FORCING_STRATEGY >= 4
#if FORCING_STRATEGY == 4
{-# ANN module (SeqaidAnnExclude "duty") #-}
#endif
#if FORCING_STRATEGY == 5
{-# ANN module (SeqaidAnnExclude "duty") #-}
#endif
#if STATS
duty :: StdGen -> Pattern -> State -> Int -> Int64 -> IO Int
duty g pat state ii last_total_bytes_allocated = do
#else
duty :: StdGen -> Pattern -> State -> Int -> IO Int
duty g pat state ii = do
#endif
#else
-- Or shouldn't this be == 4 || == 5, now? (It might not matter;
-- if it works Excluded with 4, it'll work Excl. with 6.)
-- Later: I'm not sure that's true; will see as the smoke clears...
#if FORCING_STRATEGY >= 4
-- this works whether ANN on or off:
{-# ANN module (SeqaidAnnExclude "duty") #-}
#endif
#if STATS
duty :: StdGen -> Pattern -> State -> Int -> Int64 -> IO Int
duty g pat state ii last_total_bytes_allocated = seqaidDispatch $ do
#else
duty :: StdGen -> Pattern -> State -> Int -> IO Int
duty g pat state ii = seqaidDispatch $ do
--duty g pat state ii = do -- see "tail call" for the manual injection
#endif
#endif
let (r,g') = random g :: (Bool,StdGen)
let (A2 (B3 i1
(A1 i2)
#if USE_STRICT_BLOB
(B2 (C3 (C2 i3) blob lst (C2 i4))))
#else
(B2 (C3 (C2 i3) lst (C2 i4))))
#endif
i5
(C1 i6 (C2 i7))) = state
#if USE_GROWING_LIST && USE_GROWING_LIST_REDUCTION
let lst' = if 0 == ii `mod` 5000
then [ii] else (ii:lst)
#else
let lst' = lst
#endif
let state' = if r then state else
let state_ = A2 (B3 (1+i1)
(A1 (1+i2))
#if USE_STRICT_BLOB
(B2 (C3 (C2 (1+i3)) blob lst' (C2 (1+i4)))))
#else
(B2 (C3 (C2 (1+i3)) lst' (C2 (1+i4)))))
#endif
(1+i5)
(C1 (1+i6) (C2 (1+i7))) in
#if FORCING_STRATEGY == 0
state_
#elif FORCING_STRATEGY == 1
force $ state_
#elif FORCING_STRATEGY == 2
forcen 6 $ state_
#elif FORCING_STRATEGY == 3
forcep_ pat $ state_
#elif FORCING_STRATEGY == 4
seqaid state_
-- seqaid $ state_
#elif FORCING_STRATEGY == 5
pure_escape state_
#elif FORCING_STRATEGY == 6
state_
#endif
-- Unless you do this, the forcing code above never runs:
evaluate state' -- forces only the head! (a way to place demand)
#if 0
#if DBG
when ( True ) $ do
#else
when ( 0 == ii `mod` 5000 ) $ do
#endif
-- threadDelay 500
#if DBG
putStr ".\n"
#else
putStr "."
#endif
hFlush stdout
#endif
#if STATS
new_total_bytes_allocated
<- if 0 == ii `mod` report_period
then do
stats <- getGCStats
let bytes = bytesAllocated stats
putStrLn $ pad 15 (show (currentBytesUsed stats))
++ pad 15 (show (bytes - last_total_bytes_allocated))
return $ bytesAllocated stats
else return last_total_bytes_allocated
#else
#if 0
when ( 0 == ii `mod` report_period ) $ do
-- threadDelay 500
putStr "."
hFlush stdout
#endif
#endif
-- (However, the interesting case is when pat' changes dynamically...
-- That is what happens with FORCING_STRATEGY >= 4.)
let pat' = pat
let ii' = 1+ii
if ii' < duration
then do
#if STATS
duty g' pat' state' ii' new_total_bytes_allocated
#else
duty g' pat' state' ii'
-- seqaidDispatch (duty g' pat' state' ii')
#endif
else do
return ii'
-------------------------------------------------------------------------------
-- XXX Yep, still true! So it's not only a matter of
-- the == 5 || == 6 construct!
-- XXX Must be commented out, for TH not to complain;
-- the problem with Cabal flags not reaching TH passes
-- in such cases (sometimes)...
#if 0
#if FORCING_STRATEGY == 5
{-# NOINLINE pure_escape #-}
-- XXX This is still needed, until we decide what to do about
-- auto-instrumenting monadic binds...
pure_escape :: State -> State
pure_escape state = state
#endif
#endif
-------------------------------------------------------------------------------
#if FORCING_STRATEGY >= 4
{-# ANN module (SeqaidAnnExclude "initState") #-}
{- NOINLINE initState #-} -- does not help linker errors I'm getting!...
#endif
initState :: State
#if USE_STRICT_BLOB
initState = let blob = bigstrictblob 3000 in
A2 (B3 0 (A1 0) (B2 (C3 (C2 0) blob [] (C2 0)))) 0 (C1 0 (C2 0))
#else
initState = A2 (B3 0 (A1 0) (B2 (C3 (C2 0) [] (C2 0)))) 0 (C1 0 (C2 0))
#endif
#if FORCING_STRATEGY >= 4
{-# ANN module (SeqaidAnnExclude "bigstrictblob") #-}
#endif
bigstrictblob :: Int -> Blob Int
bigstrictblob n = Blob (take n [1,2..])
-------------------------------------------------------------------------------
#if FORCING_STRATEGY >= 4
{-# ANN module (SeqaidAnnExclude "setList") #-}
#endif
setList :: [Int] -> State -> State
#if USE_STRICT_BLOB
setList lst (A2 (B3 i1 (A1 i2) (B2 (C3 (C2 i3) blob _ (C2 i4)))) i5 c1)
= (A2 (B3 i1 (A1 i2) (B2 (C3 (C2 i3) blob lst (C2 i4)))) i5 c1)
#else
setList lst (A2 (B3 i1 (A1 i2) (B2 (C3 (C2 i3) _ (C2 i4)))) i5 c1)
= (A2 (B3 i1 (A1 i2) (B2 (C3 (C2 i3) lst (C2 i4)))) i5 c1)
#endif
-------------------------------------------------------------------------------
#if STATS
pad :: Int -> String -> String
pad n s = (take (n-len) $ repeat ' ') ++ s
where len = length s
#endif
-------------------------------------------------------------------------------
-- Later: Now we always do it via seqaidpp.
#if 0
-- Now seeing if can inject with seqaidpp...
#if ! TEST_SEQAIDPP
#if FORCING_STRATEGY >= 5
seqaidTH
#endif
#endif
#endif
-------------------------------------------------------------------------------
-- Now done via seqaidpp.
#if 0
deriveGeneric ''TA
deriveGeneric ''TB
deriveGeneric ''TC
#endif
-------------------------------------------------------------------------------