seqaid-0.2.1.1: Seqaid/Optim.hs
-------------------------------------------------------------------------------
{- OPTIONS_GHC -O2 #-}
{-# LANGUAGE CPP #-}
-- 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? (maybe more...)
-------------------------------------------------------------------------------
-- |
-- Module : Seqaid.Optim
-- Copyright : Andrew G. Seniuk 2014-2015
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : Andrew Seniuk <rasfar@gmail.com>
-- Stability : provisional
-- Portability : GHC (uses global IORefs)
--
-- Harness morphological code.
--
-- The optimiser is just barely begun, but implementing it is
-- straight-forward Haskell programming, as contrasted with most
-- of the supporting infrastructure.
module Seqaid.Optim (
run_IO_SM ,
optimIO ,
) where
-------------------------------------------------------------------------------
import Control.DeepSeq.Bounded
import Data.Typeable ( Typeable )
-- Stuff for monitoring resource use (i.e. computing objective function):
import GHC.Int ( Int64 )
import Data.IORef
#if SEQABLE_ONLY
-- I've seen this one displayed, so going with the more formal name:
import Generics.SOP.Universe ( Generic )
--import Generics.SOP ( Generic )
#endif
#if 0
#if ! DEMO_MODE
import qualified Data.HashTable.IO as H
#endif
#endif
import Control.Concurrent ( myThreadId )
--import Debug.Trace ( trace )
#if SAI_FORK
import Seqaid.Optim_sai
#endif
-------------------------------------------------------------------------------
import Seqaid.Global ( depth_ioref )
#if DEMO_MODE
import Seqaid.Global ( pattern_ioref )
#else
import Seqaid.Global ( patterns_ioref )
#endif
import Seqaid.Global ( snk_ioref )
import Seqaid.Global ( stats_query_idx_ioref )
import Seqaid.Global ( counter_ioref )
import Seqaid.Global ( next_sample_at_ioref )
import Seqaid.Global ( bytes_allocated_ioref )
import Seqaid.Global ( bytes_allocated_prev_ioref )
import Seqaid.Global ( current_bytes_used_ioref )
import Seqaid.Global ( update_bytes_allocated_ioref )
--depth_ioref :: IORef Int
--pattern_ioref :: IORef Pattern
--patterns_ioref :: IORef (HashTable Int Pattern)
--snk_ioref :: IORef SeqNode
--stats_query_idx_ioref :: IORef Int
--counter_ioref :: IORef Int64
--next_sample_at_ioref :: IORef Int64
--bytes_allocated_ioref :: IORef Int64
--bytes_allocated_prev_ioref :: IORef Int64
--current_bytes_used_ioref :: IORef Int64
--update_bytes_allocated_ioref :: IO Int64
--type HashTable k v = H.CuckooHashTable k v
-------------------------------------------------------------------------------
import Seqaid.Global ( update_current_bytes_used_ioref )
import Seqaid.Global ( max_depth )
import Seqaid.Global ( sample_period )
import Seqaid.Global ( fixed_pat_sequence )
import Seqaid.Global ( SiteID )
-------------------------------------------------------------------------------
-- The plan is to keep this module pure.
-- So, it must be up the call chain someplace that
-- the IORef operations occur.
--
-- XXX Since that sounds like boilerplate, it might be
-- a good idea to offer a wrapper to the pure, here,
-- which also takes care of the IORef stuff...
-------------------------------------------------------------------------------
-- | This is for internal use only.
--
-- /The seemingly redundant superclass constraints are necessary/
-- /due to some weirdness in the TH or Core code (I forget the/
-- /details); should try to get rid of them in case it's/
-- /since become possible.../
{--}
-- Okay!
-- Now it is time to use the hash values
{--}
-- XXX This is simply the collected unsafePerformIO calls
-- that were initially scattered throughout seqaidDispatch.
-- It happened to behave the same as that did, without change;
-- but a once-over reorganising the logic slightly would be good...
{--}
-- is this pragma necessary? does it even make sense with IO?...
{-# NOINLINE run_IO_SM #-}
#if SEQABLE_ONLY
run_IO_SM :: (Generic a,Typeable a)
=> SiteID -> a -> IO (Int,Int,Pattern,SeqNode,Int64,Int64,Int64,Int64,Int64)
#else
#if NFDATAN_ONLY
run_IO_SM :: (NFDataN a,Typeable a)
=> SiteID -> a -> IO (Int,Int,Pattern,SeqNode,Int64,Int64,Int64,Int64,Int64)
#else
run_IO_SM :: (NFData a,NFDataN a,Typeable a,NFDataP a)
=> SiteID -> a -> IO (Int,Int,Pattern,SeqNode,Int64,Int64,Int64,Int64,Int64)
#endif
#endif
run_IO_SM sid x = do
--- myThreadId >>= writeIORef deepseq_bounded_ioref__main_thread_id
stats_query_idx <- do
sqi <- readIORef stats_query_idx_ioref
return sqi
depth <- do
d <- readIORef depth_ioref
return d
#if 0
-- XXX a code fragment expected to be useful (see seqaidDispatch where clause)
tmp = stats_query_idx-(2+max_depth)
pat' | tmp < length fixed_pat_sequence
= fixed_pat_sequence!!tmp
| otherwise
= last fixed_pat_sequence
#endif
#if SEQABLE_ONLY
let pat = emptyPat
#else
#if NFDATAN_ONLY
--- #error "NFDATA_ONLY is not valid at this time."
let pat = emptyPat
#else
pat <- do
#if 1 || DEMO_MODE
let tmp = stats_query_idx
-- let tmp = stats_query_idx-(2+max_depth)
let p | tmp < length fixed_pat_sequence
= fixed_pat_sequence!!tmp
| otherwise
= last fixed_pat_sequence
tid <- myThreadId
let p' = fmap (setPatNodePingParentTID tid) p
#if 0
H.insert ht sid_hash p'
#endif
return p'
#else
ht <- readIORef patterns_ioref
let sid_hash = thd3 sid
mp <- H.lookup ht sid_hash
if isNothing mp
then do
let p = emptyPat
H.insert ht sid_hash p
return p
else do
return $ fromJust mp
#endif
#endif
#endif
#if SEQABLE_ONLY
let snk = Propagate
#else
let snk = Propagate -- just whatever
#endif
i <- do
ii <- readIORef counter_ioref
modifyIORef' counter_ioref (1+)
return ii
t <- do
tt <- readIORef next_sample_at_ioref
return tt
(size,cbu,t') <-
if i >= t
then do
modifyIORef' next_sample_at_ioref (+sample_period)
-- (the snd component of result is for repairing
-- a lag in the value for t shown in trace lines)
tt <- readIORef next_sample_at_ioref
ba <- update_bytes_allocated_ioref
cbu <- update_current_bytes_used_ioref
return (ba,cbu,tt)
else do
ba <- readIORef bytes_allocated_ioref
cbu <- readIORef current_bytes_used_ioref
return (ba,cbu,t)
if i >= t
then do
modifyIORef' stats_query_idx_ioref (1+)
return ()
else return ()
#if 0
if stats_query_idx >= max_depth && i >= t
then do
let j = stats_query_idx - max_depth
writeIORef pattern_ioref (fixed_pat_sequence!!j)
return ()
else return ()
#endif
if depth <= max_depth && i >= t
then do
#if 1
modifyIORef' depth_ioref (1+)
#else
-- XXX need Data instances...
-- writeIORef pattern_ioref (mkPatN depth x)
#endif
return ()
else return ()
optimIO
--- (!_,!_,!_,!_,!_,!_,!_,!_,!_) <- optimIO -- XXX (as if XXX is nec. lol!)
-- At the moment, this no longer seems necessary at all.
-- (But maybe it was for when first getting it working,
-- and sample_period was 1 [or at least small]; and
-- when the test program did little work...).
-- XXX Note that if we can avoid this, there is another benefit:
-- We don't necessarily WANT to force the head of x! (forcen 0,
-- or forcep "#")...
--- _ <- return $! x -- works as well?...
!_ <- return x -- magic! thank you!!
return (stats_query_idx,depth,pat,snk,i,t,size,cbu,t')
-- return ()
-------------------------------------------------------------------------------
#if ! SAI_FORK
optimIO :: IO ()
optimIO = return ()
#endif
-------------------------------------------------------------------------------