module Seqaid.Runtime (
SiteID
, seqaidDispatch
, seqaidDispatchDyn
) where
import Control.DeepSeq.Bounded
import Data.Typeable ( typeOf )
import Data.Typeable ( Typeable )
import Seqaid.Global (
SiteID
, max_depth
, fixed_pat
)
import Seqaid.Optim
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
#if SEQABLE_ONLY
seqaidDispatch :: (
#if SHOW_TYPE
Typeable a,
#endif
Generic a) =>
SiteID ->
a -> a
seqaidDispatch
sid
x =
#if DBG_SEQAID
if 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
seqaidDispatch :: (
#if SHOW_TYPE
Typeable a,
#endif
NFDataN a) =>
SiteID ->
a -> a
seqaidDispatch
sid
x =
#if DBG_SEQAID
if i >= t
then
trace (">>> N "
++snd3 sid++"\t"
++show stats_query_idx++" "
++show (i,t,size)++" "
#if SHOW_TYPE
++show (typeOf x)
#endif
) $
#endif
x'
else x'
#else
seqaidDispatch :: forall a. (NFData a,NFDataN a,Typeable a,NFDataP a) =>
SiteID ->
a -> a
seqaidDispatch
sid
x =
#if DBG_SEQAID
#if 1
if 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'))++" "
++padr 8 (dropQuals (snd3 sid))
++padl 8 (show cbu)++" "
++padl 9 (show size)++" "
++show (typeOf x)
) $
x'
else x'
#else
if 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
++(if stats_query_idx <= (1+max_depth) then (padr 40 (show depth)) else padr 40 (showPat pat'))++" "
++padl 2 (show (fst3 sid))++" "
++snd3 sid++"\t"
++padl 3 (show stats_query_idx)++" "
++padl 11 (show cbu)++" "
++padl 11 (show size)++" "
++show (typeOf x)
) $
x'
else x'
#endif
#endif
#endif
#endif
where
( stats_query_idx, depth, pat, snk, i, t, size, cbu, t')
= unsafePerformIO $! run_IO_SM sid x
#if 0
#elif 1
x' = unsafePerformIO $ handle f $ do
evaluate x''
return x''
f = (\ (DeepSeqBounded_PingException msg)
-> do
#if 1
putStr (msg::String)
#else
hPutStrLn stderr msg
hFlush stderr
#endif
#if 0
hPutStrLn stderr "EXCEPTION ACTION"
hFlush stderr
#endif
return x'')
#elif 0
x' = unsafePerformIO $ evaluate x'' `catch` f
f = (\ () -> do
#if 0
hPutStrLn stderr "EXCEPTION ACTION"
hFlush stderr
#endif
return x'')
#elif 0
x' = unsafePerformIO $ evaluate x'' `catchJust'` f
catchJust' = catchJust ep
ep = (\e -> if isDeepSeqBounded_PingException e then Just () else error "BOO!" )
f = (\ () -> do
#if 0
hPutStrLn stderr "EXCEPTION ACTION"
hFlush stderr
#endif
evaluate x''
return x'')
#endif
isDeepSeqBounded_PingException DeepSeqBounded_PingException{} = True
isDeepSeqBounded_PingException _ = False
#if SEQABLE_ONLY
x'' = force_ snk x
#else
#if NFDATAN_ONLY
x'' = forcen depth x
#else
pat' = pat
x'' | stats_query_idx <= (1+max_depth)
= forcep_ pat x
| otherwise
= forcep_ pat x
#endif
#endif
#if SEQABLE_ONLY
seqaidDispatchDyn :: Generic a => SiteID -> a -> a
seqaidDispatchDyn _ x = x'
where
t = show $ typeOf x
x' | False = undefined
| t == "TA" = force_ Propagate x
| t == "TB" = force_ Propagate x
| t == "TC" = force_ Propagate x
| otherwise = x
#else
#if NFDATAN_ONLY
seqaidDispatchDyn :: (Typeable a,NFDataN a) => SiteID -> a -> a
seqaidDispatchDyn _ x = x'
where
t = show $ typeOf x
x' | t == "TA" = forcen max_depth x
| otherwise = x
#else
seqaidDispatchDyn :: (NFData a,NFDataN a,Typeable a,NFDataP a) =>
SiteID -> a -> a
seqaidDispatchDyn _ x = x'
where
t = show $ typeOf x
x' | t == "TA" = forcep_ fixed_pat x
| 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
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