------------------------------------------------------------------------------- -- XXX I'm not entirely happy with the way Haskell has -- twisted my arm to arrange the modules, but there you go. {- OPTIONS_GHC -O2 #-} {-# LANGUAGE CPP #-} -- Later: This (now) has no effect when new grammar is in effect. -- This is temporary, so seqaid demo output remains compatible -- with the documentation already written around it. (The new -- shrinkPat has more finesse, but you have to run the demo -- longer to see the heap stabilise -- the demonstration is -- not nearly as effective. Also, the patterns have a lot -- of #'s in them which looks noisy and confusing, although -- it's natural enough.) We could attempt vertical alignment -- since flanking whitespace is now supported, and that would -- do more than anything to improve the presentation... -- However, with DEMO_MODE off, one would definitely prefer -- the new shrinkPat. This comment will probably be -- as writ on water... #define USE_OLD_SHRINK_PAT 0 -- XXX Should scour the code for "max_depth" etc. -- all those -- names which are specific to this DEMO_MODE hack!... And get -- them into CPP guards. And get something sane in the OTHER -- branches of those guards!!... -- (Switch now promoted to .cabal flag.) --- #define DEMO_MODE 1 {- LANGUAGE BangPatterns #-} -- for debugging only ------------------------------------------------------------------------------- -- | -- Module : Seqaid.Global -- Copyright : Andrew G. Seniuk 2014-2015 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Andrew Seniuk <rasfar@gmail.com> -- Stability : provisional -- Portability : GHC -- -- Collects 'IORef's used by the seqaid runtime. -- -- This will be substantially reorganised and clarified soon. module Seqaid.Global ( #if DEMO_MODE depth_ioref , pattern_ioref , snk_ioref , #endif #if ! DEMO_MODE patterns_ioref , #endif stats_query_idx_ioref , counter_ioref , next_sample_at_ioref , bytes_allocated_ioref , bytes_allocated_prev_ioref , current_bytes_used_ioref , update_bytes_allocated_ioref , update_current_bytes_used_ioref , SiteID , sample_period , max_depth , fixed_pat , fixed_pat_sequence , ) where ------------------------------------------------------------------------------- import Control.DeepSeq.Bounded import Data.Typeable ( Typeable ) -- Stuff for monitoring resource use (i.e. computing objective function): --import Data.Word ( Word64 ) import GHC.Int ( Int64 ) import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) import System.Mem ( performGC ) import GHC.Stats ( GCStats(..), getGCStats ) --import Debug.Trace ( trace ) --import Data.Array #if ! DEMO_MODE import qualified Data.HashTable.IO as H #endif ------------------------------------------------------------------------------- #if ! DEMO_MODE type HashTable k v = H.CuckooHashTable k v {-# NOINLINE patterns_ioref #-} patterns_ioref :: IORef (HashTable Int Pattern) patterns_ioref = unsafePerformIO $ do ht <- H.new ioref <- newIORef ht return ioref #endif ------------------------------------------------------------------------------- -- This group is very temporary!) -- definitely temporary hack (uniform forcing depth regardless of SiteID) {-# NOINLINE depth_ioref #-} depth_ioref :: IORef Int depth_ioref = unsafePerformIO $ newIORef 0 -- definitely temporary hack (uniform Pattern regardless of SiteID) {-# NOINLINE pattern_ioref #-} pattern_ioref :: IORef Pattern pattern_ioref = unsafePerformIO $ newIORef $ emptyPat -- definitely temporary hack (uniform SeqNode regardless of SiteID) {-# NOINLINE snk_ioref #-} snk_ioref :: IORef SeqNode snk_ioref = unsafePerformIO $ newIORef Insulate ------------------------------------------------------------------------------- {-# NOINLINE stats_query_idx_ioref #-} stats_query_idx_ioref :: IORef Int --stats_query_idx_ioref :: IORef Int64 stats_query_idx_ioref = unsafePerformIO $ newIORef 0 {-# NOINLINE counter_ioref #-} counter_ioref :: IORef Int64 counter_ioref = unsafePerformIO $ newIORef 0 {-# NOINLINE next_sample_at_ioref #-} next_sample_at_ioref :: IORef Int64 next_sample_at_ioref = unsafePerformIO $ newIORef sample_period --next_sample_at_ioref = unsafePerformIO $ newIORef 0 {-# NOINLINE bytes_allocated_ioref #-} bytes_allocated_ioref :: IORef Int64 bytes_allocated_ioref = unsafePerformIO $ newIORef 0 {-# NOINLINE bytes_allocated_prev_ioref #-} bytes_allocated_prev_ioref :: IORef Int64 bytes_allocated_prev_ioref = unsafePerformIO $ newIORef 0 {-# NOINLINE current_bytes_used_ioref #-} current_bytes_used_ioref :: IORef Int64 current_bytes_used_ioref = unsafePerformIO $ newIORef 0 ------------------------------------------------------------------------------- {-# NOINLINE update_bytes_allocated_ioref #-} update_bytes_allocated_ioref :: IO Int64 update_bytes_allocated_ioref = do oldsize <- readIORef bytes_allocated_ioref writeIORef bytes_allocated_prev_ioref oldsize performGC gcstats <- getGCStats let newsize = bytesAllocated gcstats #if 0 putStrLn $ "\nsize="++show size i <- readIORef counter_ioref t <- readIORef next_sample_at_ioref putStrLn $ "i="++show i++"\nt="++show t #endif writeIORef bytes_allocated_ioref newsize return $! newsize - oldsize -- return newsize ------------------------------------------------------------------------------- {-# NOINLINE update_current_bytes_used_ioref #-} update_current_bytes_used_ioref :: IO Int64 update_current_bytes_used_ioref = do performGC gcstats <- getGCStats let cbu = currentBytesUsed gcstats writeIORef current_bytes_used_ioref cbu return cbu ------------------------------------------------------------------------------- sample_period :: Int64 --sample_period = 1 --sample_period = 10 --sample_period = 400 --sample_period = 1000 sample_period = 4000 -- the usual for leaky-full --sample_period = 10000 -- XXX quack! (6 is minimal; 5 is too small; the leak remains) max_depth = 7 :: Int fixed_pat_sequence = let shrink_pat | deepseq_bounded_flag__new_improved_pattern_grammar = shrinkPat #if USE_OLD_SHRINK_PAT | otherwise = shrinkPat_old #else | otherwise = shrinkPat #endif in ( map (\i -> compilePat ('*':show i)) [0,1..8] ) ++ ( reverse $ condenseEq shrink_pat fixed_pat ) -- [Debugging notes for recent changes to deepseq-bounded.] -- leaky: DeepSeqBounded_PingException "NFDataP: PING: 0 Int\n()\n" -- leaky: DeepSeqBounded_PingException "NFDataP: PING: 1 Int\n()\n" -- leaky: DeepSeqBounded_PingException "NFDataP: PING: 3 Int\n()\n" -- leaky: DeepSeqBounded_PingException "NFDataP: PING: 7 Int\n()\n" -- leaky: DeepSeqBounded_PingException "NFDataP: PING: 12 Int\n()\n" -- leaky: DeepSeqBounded_PingException "NFDataP: PING: 13 Int\n()\n" -- leaky: DeepSeqBounded_PingException "NFDataP: PING: 14 Int\n()\n" -- This is what we see. If wait (only see 0 repeating for a while). -- (And the system grinds to a crawl, although it appears to be -- a stable crawl.) ----- -- See cotemp (20150111130916) 000-readme for the labelling of the tree... -- This mystery is largely solved. As for "slowdown" well, it's no -- wonder if we're trying to print something for every one of the -- gizillion exceptions, but if it was a quick stats update or something, -- might actually be fine at full speed... -- Speaking of "speed", a threadDelay-type attribute would be useful... -- Too useful not to do it! (Except that threadDelay is known to be -- a bit flakey...). (But you gotta try...) #if 1 fixed_pat | deepseq_bounded_flag__new_improved_pattern_grammar = setPatternPatNodeUniqueIDs 0 $ -- compilePat "=>cab((!(!)(((^!).!(!))))!(^!(!)))" -- compilePat "=>cab((!(!)(((+!).!(!))))!(+!(!)))" -- compilePat "((!(!)(((+^/!).!(!))))!(!(!)))" -- compilePat "((!(!)(((+^!).!(!))))!(!(!)))" -- compilePat "+^(+^(+^!+^(+^/!)+^/(+^/(+^/(+^/!)+^/.+^/!+^/(+^/!))))+^/!+^/(+^/!+^/(+^/!)))" -- compilePat "+^/(+^/(+^/!+^/(+^/!)+^/(+^/(+^/(+^/!)+^/.+^/!+^/(+^/!))))+^/!+^/(+^/!+^/(+^/!)))" -- compilePat "+^(+^(+^!+^(+^!)+^(+^(+^(+^!)+^.+^!+^(+^!))))+^!+^(+^!+^(+^!)))" -- compilePat "((!(!)+(+(+(+!).!(!))))!(!(!)))" -- yes, it works (if you wait a wee bit) -- trying the full-blanket-+'d one again!!! -- compilePat "((!(!)(((+!).!(!))))!+(!(!)))" -- -- compilePat "((!(!)((+(+!).!(!))))!(!(!)))" -- ACTUALLY WORKS -- at FIRST you see only TC, then after the next stats line you see "4 TC / 3 Int" (or maybe the other way around, but I think this is the order...) -- compilePat "((!(!)(((+!).!(!))))!(!(!)))" -- still works -- XXX Oh, I see what happened: I made !(!) -> . at some point, -- as part of testing, and this got propagated and forgotten, -- and changed back . -> ! (instead of !(!)) -- but this is -- harmless actually?!!! -- compilePat "((!(!)(((+^!)+^/.!(!))))!(!(!)))" -- compilePat "((!+^/.(((!)+^/.!(!))))!(!(!)))" -- nothing. -- compilePat "+(+(+!+(+!)+(+(+(+!).!(!))))!(!(!)))" -- XXX XXX -- compilePat "(+(!+.(+((!)+.!(!))))!(!(!)))" ---- compilePat "((!(!)((+.(!)+.+!(!))))!(!(!)))" ----- compilePat "+(+(+!+!+(+(+(+!).!(!))))!(!(!)))" -- XXX XXX -- compilePat "+(+(+!+(+!)+(+(+(+!).!(!))))!(!(!)))" -- XXX XXX -- compilePat "((+!^(!)(+((!).+^!/^(+^!))))!(!(!)))" -- yep -- compilePat "((+!^(!)(+((!).+^!^(+^!))))!(!(!)))" -- all working -- compilePat "((!(+^/.)(((!)+^/.!+^/.)))!(!(!)))" -- nothing -- compilePat "((!(/.)(((!)/.!/.)))!(!(!)))" -- nothing --- compilePat "((!/.(((!)/.!(!))))!(!(!)))" -- nope, neither calls handleAttrs (incididentally, this leaks noticeably and monotonically, while the one with just . on the Blob, if not technically leak-free [? it seems to accumulate heap and then periodically discharge it, notwithstanding our frequent performGC calls...], at least not exhibiting net growth over longrunning...) This is a better test at the moment as the first . is of simple base nullary type Int. -- compilePat "((!(!)(((!)/.!(!))))!(!(!)))" -- the problem with this test is that the .'d node is of unusual type Blob, which has hack NFData instances etc... --- compilePat "((!+.(((!)+.+!(!))))+!(!(+!)))" --- compilePat "((+!+.((+(+!)+.!(!))))+!(!(+!)))" --- compilePat "((!+.(((!)+.!(!))))!(!(!)))" --- compilePat "((!.(((!)+.!(!))))!(!(!)))" --- compilePat "((!.(((!)+.!(!))))!(!(!)))" -- compilePat "((!(!)(((!)+.!(!))))!(!(!)))" -- compilePat "+(+(+!+(+!)+(+(+(+!)+.+!+(+!))))+!+(+!+(+!)))" -- this is working now for generic nodes, but NOT for any of the others; so we see it for exactly the OTHER 9 nodes not among the 8 listed below! ch!... [later: fixed GNFDataP] -- compilePat "^(^(^!^(^!)^(^(^(^!)^.^!^(^!))))^!^(^!^(^!)))" -- AMAZINGLY WORKS!!! See IDs 0 1 3 7 12 13 14 -- compilePat "((!(!)(((^!).!(!))))!(!(!)))" -- works -- compilePat "((!(!)(((!).^!(!))))!(!(!)))" -- NO WORKY: FREEZES (same) #if 0 -- (Reproducible serious bug!) -- compilePat "((!(!)(((!).+!(!))))!(!(!)))" -- NO WORKY: FREEZES -- AFTER "trc msg.": --- P (( ()((() + ()))) ( ())) duty 918272 8720160 TA --- P ((!(!)(((!) +!(!))))!(!(!))) duty 1660356 2185992 TA --- P ((!(!)(((!) +!(!))))!(!(!))) duty 2348988 2244528 TA --- P ((!(!)(((!) +!(!))))!(!(!))) duty 3037620 2240528 TA --- P ((!(!)(((!) +!(!))))!(!(!))) duty 3693484 2207760 TA --- trc msg. --- ^C #endif -- compilePat "((!(!)(((!)+.!(!))))!(!(!)))" -- NO WORKY -- compilePat "((!(!)(((+!).!(+!))))!(!(!)))" -- works! "(TRACE: 3 Int) (TRACE: 7 Int)" repeating -- compilePat "((!(!)(((!).!(+!))))!(!(!)))" -- works! "(TRACE: 7 Int)" -- compilePat "((!(!)(((!)+^/.!(!))))!(!(!)))" -- no worky! -- compilePat "(+^/(!(!)(((!).!(!))))!(!(!)))" -- no worky -- compilePat "(+(!(!)(((!).!(!))))!(!(!)))" -- no worky -- compilePat "(+(!(!)(((+!).!(!))))!(!(!)))" -- compilePat "((!(!)(((+!).!(!))))!(!(!)))" -- works! "(TRACE: 3 Int)" compilePat "((!(!)(((!).!(!))))!(!(!)))" | otherwise = compilePat ".{.{..{.}.{.{.{.}#..{.}}}}..{..{.}}}" #else fixed_pat = compilePat ".{.{..{.}.{.{.{.}#..{.}}}}..{..{.}}}" #endif ------------------------------------------------------------------------------- -- From SAI.Data.Generics.Shape.SYB.Filter: condenseEq :: Eq a => (a -> a) -> a -> [a] -- beware this can diverge condenseEq f z = condenseEq' $ iterate f z where condenseEq' (x:y:t) | x == y = [x] | otherwise = x : condenseEq' (y:t) -- no other cases needed -- we know the argument is infinite ------------------------------------------------------------------------------- -- XXX Using a triple (esp. the 3rd component) is probably not -- the most performant choice... optimisation pending... -- XXX Would prefer 1 <-> 2, but to do that would require more -- code change to test... -- XXX This is no doubt located here to avoid a cyclical import! -- 1 (Int) Contains index of forcing site in the AST of the binding. -- 2 (String) Contains site binding variable name. -- 3 (Int) Caches the "unique" Int hash of name extended by index. type SiteID = (Int,String,Int) -------------------------------------------------------------------------------