seqaid-0.4.0.0: Seqaid/Runtime.hs
-------------------------------------------------------------------------------
{- OPTIONS_GHC -O2 #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-} -- for debugging only (maybe for more...)
{-# LANGUAGE ScopedTypeVariables #-}
-------------------------------------------------------------------------------
-- |
-- Module : Seqaid.Runtime
-- Copyright : Andrew G. Seniuk 2014-2015
-- License : BSD-style (see the file LICENSE)
--
-- Maintainer : Andrew Seniuk <rasfar@gmail.com>
-- Stability : provisional
-- Portability : GHC (unsafePerformIO)
--
-- This module is for seqaid internal use.
--
-- /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.../
module Seqaid.Runtime (
SiteID -- re-export
, seqaidDispatch
, seqaidDispatchDyn
-- would be best if could... (less for plugin/lib user to do)
-- , module Control.DeepSeq.Bounded
-- , Typeable
) where
-------------------------------------------------------------------------------
import Control.DeepSeq.Bounded
import Data.Typeable ( typeOf )
import Data.Typeable ( Typeable )
import Seqaid.Global (
SiteID
--- , run_IO_SM -- moved to Optim [not ideal, but...]
-- , sample_period
, max_depth
-- , fixed_pat_sequence
, fixed_pat
)
import Seqaid.Optim
-- (for monitoring resource use, and computing objective function)
import System.IO.Unsafe ( unsafePerformIO )
import Debug.Trace ( trace )
#if SEQABLE_ONLY
import Generics.SOP ( Generic )
#endif
import Control.Exception
import System.IO
import System.IO.Error
-------------------------------------------------------------------------------
{-# NOINLINE seqaidDispatch #-}
#if SEQABLE_ONLY
seqaidDispatch :: (
#if SHOW_TYPE
--- #warning "WARNING-2"
Typeable a,
#endif
Generic a) =>
SiteID ->
a -> a
seqaidDispatch
sid
x =
#if DBG_SEQAID
if {- True || -} i >= t
then
trace (">>> S "
++snd3 sid++"\t"
++show stats_query_idx++" "
++show (i,t,size)++" "
#if SHOW_TYPE
++show (typeOf x)
#endif
) $
#endif
x'
else x'
#else
#if NFDATAN_ONLY
--- #warning "WARNING-1"
-- It's very tempting to write this with the CPP subconditionals deeper in...
seqaidDispatch :: (
#if SHOW_TYPE
--- #warning "WARNING-2"
Typeable a,
#endif
NFDataN a) =>
SiteID ->
a -> a
seqaidDispatch
sid
x =
#if DBG_SEQAID
if {- True || -} i >= t
then
trace (">>> N "
-- trace ("SEQAIDDISPATCH N "
++snd3 sid++"\t"
++show stats_query_idx++" "
++show (i,t,size)++" "
#if SHOW_TYPE
++show (typeOf x)
#endif
) $
#endif
x'
else x'
#else
-- XXX Question: Are all the superclass constraints still needed?
-- There was a time when they were. (Although they're implicit
-- for normal Haskell compilation, for whatever I was doing either
-- in TH or in Core, they were needed to get them in scope.
seqaidDispatch :: forall a. (NFData a,NFDataN a,Typeable a,NFDataP a) =>
SiteID ->
a -> a
seqaidDispatch
sid
x =
#if DBG_SEQAID
#if 1
-- 80 cols
if i >= t
-- if True || i >= t
then
trace ((if stats_query_idx == 0 then " live alloc\n" else "")++(if stats_query_idx <= (1+max_depth) then " N " else " P ")
++(if stats_query_idx <= (1+max_depth) then (padr 30 (show depth)) else padr 30 (showPat pat'))++" "
-- ++padl 2 (show (fst3 sid))++" "
++padr 8 (dropQuals (snd3 sid))
-- ++padl 3 (show stats_query_idx)++" "
++padl 8 (show cbu)++" "
++padl 9 (show size)++" "
-- ++show (cbu, size)++" "
-- ++show (i, size)++" "
-- ++show (i,t',size)++" "
++show (typeOf x)
) $
x'
else x'
#else
-- 110 cols
if i >= t
-- if True || i >= t
then
#if 1
trace ((if stats_query_idx == 0 then " live heap alloc\n" else "")++(if stats_query_idx <= (1+max_depth) then ">>> N " else ">>> P ")
#else
trace (">>> P "
#endif
-- trace ("SEQAIDDISPATCH P "
++(if stats_query_idx <= (1+max_depth) then (padr 40 (show depth)) else padr 40 (showPat pat'))++" "
++padl 2 (show (fst3 sid))++" "
-- ++(if fst3 sid > 9 then "" else " ")++show (fst3 sid)++" "
++snd3 sid++"\t"
-- ++show sid++"\t"
++padl 3 (show stats_query_idx)++" "
++padl 11 (show cbu)++" "
++padl 11 (show size)++" "
-- ++show (cbu, size)++" "
-- ++show (i, size)++" "
-- ++show (i,t',size)++" "
++show (typeOf x)
) $
x'
else x'
#endif
#endif
#endif
#endif
where
( stats_query_idx, depth, pat, snk, i, t, size, cbu, t')
-- (!stats_query_idx,!depth,!pat,!snk,!i,!t,!size,!cbu,!t')
= unsafePerformIO $! run_IO_SM sid x
-- Later: Now "EXCEPTION ACTION" message /is/ printed -- twice.
-- And then we see "leaky: DeepSeqBounded_PingException",
-- on which leaky seems to die.
-----
-- Doesn't appear to work -- exception still kills whole program,
-- and no "EXCEPTION ACTION" message is printed.
#if 0
#elif 1
x' = unsafePerformIO $ handle f $ do
evaluate x''
return x''
f = (\ (DeepSeqBounded_PingException msg)
-> do
#if 1
putStr (msg::String) -- b/c showRose ends '\n'
-- putStrLn (msg::String)
#else
hPutStrLn stderr msg
hFlush stderr
#endif
#if 0
hPutStrLn stderr "EXCEPTION ACTION"
hFlush stderr
#endif
-- evaluate x''
return x'')
#elif 0
x' = unsafePerformIO $ evaluate x'' `catch` f
-- catchJust :: Exception e => (e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
f = (\ () -> do
#if 0
hPutStrLn stderr "EXCEPTION ACTION"
hFlush stderr
#endif
-- evaluate x''
return x'')
#elif 0
x' = unsafePerformIO $ evaluate x'' `catchJust'` f
catchJust' = catchJust ep
--- x' = unsafePerformIO $! evaluate x'' `catchJust'` ep f
--- catchJust' = flip catchJust
--- ep :: forall e. Exception e => e -> Maybe a
ep = (\e -> if isDeepSeqBounded_PingException e then Just () else error "BOO!" {-Nothing-})
--- ep = (\ (e::DeepSeqBounded_PingException) -> if isDeepSeqBounded_PingException $ fromException e then Just x'' else Nothing)
--- f :: DeepSeqBounded_PingException -> IO a
f = (\ () -> do
#if 0
hPutStrLn stderr "EXCEPTION ACTION"
hFlush stderr
#endif
evaluate x''
return x'')
#endif
isDeepSeqBounded_PingException DeepSeqBounded_PingException{} = True
isDeepSeqBounded_PingException _ = False
-- The constants 6 and fixed_pat are specific to the leaky-1.0 package.
-- They are minimal sufficient depth and pattern (respectively) to plug leaky.
#if SEQABLE_ONLY
x'' = force_ snk x
-- x'' = force_ Insulate x
#else
#if NFDATAN_ONLY
x'' = forcen depth x
-- x'' = forcen 6 x
#else
pat' = pat
x'' | stats_query_idx <= (1+max_depth)
= forcep pat x -- trying to use *n patterns instead
--- = forcep_ pat x -- deprecated function!
-- = forcen depth x
| otherwise
= forcep pat x
--- = forcep_ pat x -- deprecated function!
#endif
#endif
-------------------------------------------------------------------------------
#if SEQABLE_ONLY
seqaidDispatchDyn :: Generic a => SiteID -> a -> a
seqaidDispatchDyn _ x = x'
where
--- !_ = trace t ()
t = show $ typeOf x
x' | False = undefined
--- | t == "State" = force_ Propagate x -- never, right? (type synonym)
| t == "TA" = force_ Propagate x
| t == "TB" = force_ Propagate x
| t == "TC" = force_ Propagate x
| otherwise = x
--- | otherwise = force_ Insulate x
#else
#if NFDATAN_ONLY
seqaidDispatchDyn :: (Typeable a,NFDataN a) => SiteID -> a -> a
seqaidDispatchDyn _ x = x'
where
--- !_ = trace t ()
t = show $ typeOf x
x' | t == "TA" = forcen max_depth x
-- x' | t == "State" = forcen max_depth x
| otherwise = x
#else
-- [Very old function, never really used.]
-- Note that NFDataP already has Typeable superclass.
-- (This is not ideal perhaps, as a lot of NFDataP's
-- functionality doesn't depend on Typeable...).
-- See note to seqaidDispatch,
seqaidDispatchDyn :: (NFData a,NFDataN a,Typeable a,NFDataP a) =>
SiteID -> a -> a
--seqaidDispatchDyn :: NFDataP a => SiteID -> a -> a
--seqaidDispatchDyn :: NFDataP a => a -> a
--seqaidDispatchDyn :: (Typeable a,NFDataP a) => a -> a
seqaidDispatchDyn _ x = x'
where
--- !_ = trace t ()
t = show $ typeOf x
x' | t == "TA" = forcep fixed_pat x
-- x' | t == "State" = forcep fixed_pat x
--- x' | t == "TA" = forcep_ fixed_pat x -- deprecated function!
| otherwise = x
#endif
#endif
-------------------------------------------------------------------------------
padr :: Int -> String -> String
padr n s = s ++ (take (n-(length s)) $ repeat ' ')
padl :: Int -> String -> String
padl n s = (take (n-(length s)) $ repeat ' ') ++ s
-------------------------------------------------------------------------------
-- use it on (String-ified) types!... (See caveat in Core.hs.)
dropQuals :: String -> String
dropQuals = reverse . takeWhile (/= '.') . reverse
-------------------------------------------------------------------------------
fst3 :: (a,b,c) -> a
fst3 (x,_,_) = x
snd3 :: (a,b,c) -> b
snd3 (_,y,_) = y
thd3 :: (a,b,c) -> c
thd3 (_,_,z) = z
-------------------------------------------------------------------------------