seqaid-0.1.1: Seqaid/Global.hs

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

-- 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 #-}

-- This is temporary, so seqaid demo output remains compatible
-- with the documentation already written around it.
#define USE_OLD_SHRINK_PAT 1

-- 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   :  (c) 2014, Andrew G. Seniuk
-- 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
-- by the next minor version bump (>=0.1.1).

  module Seqaid.Global 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

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

  -- This one's global. (All this stuff is just QUACK stuff...).
  {-# NOINLINE depth_ioref #-}
  depth_ioref :: IORef Int
  depth_ioref = unsafePerformIO $ newIORef 0

#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
#else
  {-# NOINLINE pattern_ioref #-}
  pattern_ioref :: IORef Pattern
  pattern_ioref = unsafePerformIO $ newIORef $ compilePat "#"
#endif

  -- This one's global. (All this stuff is just QUACK stuff...).
  {-# NOINLINE snk_ioref #-}
  snk_ioref :: IORef SeqNodeKind
  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
   =    ( map (\i -> compilePat ('*':show i)) [0,1..8] )
#if USE_OLD_SHRINK_PAT
     ++ ( reverse $ condenseEq shrinkPat_old fixed_pat )
#else
     ++ ( reverse $ condenseEq shrinkPat fixed_pat )
#endif

  fixed_pat = compilePat ".{.{..{.}.{.{.{.}#..{.}}}}..{..{.}}}"

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

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

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