------------------------------------------------------------------------------- -- 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 let pat = compilePat ".{.{..{.}.{.{.{.}#..{.}}}}..{..{.}}}" -- let pat = compilePat ".{.{..{.}.{.{.{.}...{.}}}}..{..{.}}}" #else #if 0 #elif 1 let pat = mkPat state -- identical to the explicit pattern below #elif 0 let pat = compilePat ".{.{..{.}.{.{.{.}..{.}}}}..{..{.}}}" #elif 0 let pat = compilePat "*" -- should be (is) equivalent to rnf #endif #endif putStrLn $ showPat pat #else let pat = compilePat "#" #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 -------------------------------------------------------------------------------