{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE UndecidableInstances #-}

module Language.Embedded.Concurrent.Backend.C where



#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Monad.Operational.Higher
import Data.Typeable
import Language.Embedded.Expression
import Language.Embedded.Concurrent.CMD
import Language.Embedded.Imperative.CMD
import Language.Embedded.Backend.C.Expression
import Language.C.Quote.C
import Language.C.Monad
import qualified Language.C.Syntax as C



instance ToIdent ThreadId where
  toIdent :: ThreadId -> SrcLoc -> Id
toIdent (TIDComp TID
tid) = TID -> SrcLoc -> Id
C.Id TID
tid

instance ToIdent (Chan t a) where
  toIdent :: Chan t a -> SrcLoc -> Id
toIdent (ChanComp TID
c) = TID -> SrcLoc -> Id
C.Id TID
c

threadFun :: ThreadId -> String
threadFun :: ThreadId -> TID
threadFun ThreadId
tid = TID
"thread_" TID -> TID -> TID
forall a. [a] -> [a] -> [a]
++ ThreadId -> TID
forall a. Show a => a -> TID
show ThreadId
tid

-- | Compile `ThreadCMD`.
--   TODO: sharing for threads with the same body
compThreadCMD :: CompExp exp => ThreadCMD (Param3 CGen exp pred) a -> CGen a
compThreadCMD :: ThreadCMD (Param3 CGen exp pred) a -> CGen a
compThreadCMD (ForkWithId ThreadId -> prog ()
body) = do
  ThreadId
tid <- TID -> ThreadId
TIDComp (TID -> ThreadId) -> CGenT Identity TID -> CGenT Identity ThreadId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TID -> CGenT Identity TID
forall (m :: * -> *). MonadC m => TID -> m TID
gensym TID
"t"
  let funName :: TID
funName = ThreadId -> TID
threadFun ThreadId
tid
  ()
_ <- Type -> TID -> prog () -> prog ()
forall (m :: * -> *) a. MonadC m => Type -> TID -> m a -> m a
inFunctionTy [cty|void*|] TID
funName (prog () -> prog ()) -> prog () -> prog ()
forall a b. (a -> b) -> a -> b
$ do
    Param -> prog ()
forall (m :: * -> *). MonadC m => Param -> m ()
addParam [cparam| void* unused |]
    ThreadId -> prog ()
body ThreadId
tid
    Stm -> prog ()
forall (m :: * -> *). MonadC m => Stm -> m ()
addStm [cstm| return NULL; |]
  TID -> CGen ()
forall (m :: * -> *). MonadC m => TID -> m ()
addSystemInclude TID
"pthread.h"
  ThreadId -> CGen ()
forall (m :: * -> *) v. (MonadC m, ToIdent v) => v -> m ()
touchVar ThreadId
tid
  InitGroup -> CGen ()
forall (m :: * -> *). MonadC m => InitGroup -> m ()
addLocal [cdecl| typename pthread_t $id:tid; |]
  Stm -> CGen ()
forall (m :: * -> *). MonadC m => Stm -> m ()
addStm [cstm| pthread_create(&$id:tid, NULL, $id:funName, NULL); |]
  ThreadId -> CGenT Identity ThreadId
forall (m :: * -> *) a. Monad m => a -> m a
return ThreadId
tid
compThreadCMD (Kill ThreadId
tid) = do
  ThreadId -> CGen ()
forall (m :: * -> *) v. (MonadC m, ToIdent v) => v -> m ()
touchVar ThreadId
tid
  Stm -> CGen ()
forall (m :: * -> *). MonadC m => Stm -> m ()
addStm [cstm| pthread_cancel($id:tid); |]
compThreadCMD (Wait ThreadId
tid) = do
  ThreadId -> CGen ()
forall (m :: * -> *) v. (MonadC m, ToIdent v) => v -> m ()
touchVar ThreadId
tid
  Stm -> CGen ()
forall (m :: * -> *). MonadC m => Stm -> m ()
addStm [cstm| pthread_join($id:tid, NULL); |]
compThreadCMD (Sleep exp i
us) = do
  Exp
us' <- exp i -> CGenT Identity Exp
forall (exp :: * -> *) (m :: * -> *) a.
(CompExp exp, MonadC m) =>
exp a -> m Exp
compExp exp i
us
  TID -> CGen ()
forall (m :: * -> *). MonadC m => TID -> m ()
addSystemInclude TID
"unistd.h"
  Stm -> CGen ()
forall (m :: * -> *). MonadC m => Stm -> m ()
addStm [cstm| usleep($us'); |]

-- | Compile `ChanCMD`.
compChanCMD :: (CompExp exp, CompTypeClass ct, ct Bool)
            => ChanCMD (Param3 CGen exp ct) a
            -> CGen a
compChanCMD :: ChanCMD (Param3 CGen exp ct) a -> CGen a
compChanCMD cmd :: ChanCMD (Param3 CGen exp ct) a
cmd@(NewChan ChanSize exp pred i
sz) = do
  TID -> CGen ()
forall (m :: * -> *). MonadC m => TID -> m ()
addLocalInclude TID
"chan.h"
  Exp
sz' <-ChanSize exp pred i -> CGenT Identity Exp
forall (exp :: * -> *) (ct :: * -> Constraint) i.
(CompExp exp, CompTypeClass ct) =>
ChanSize exp ct i -> CGenT Identity Exp
compChanSize ChanSize exp pred i
sz
  Chan t c
c <- TID -> Chan t c
forall k k (t :: k) (a :: k). TID -> Chan t a
ChanComp (TID -> Chan t c)
-> CGenT Identity TID -> CGenT Identity (Chan t c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TID -> CGenT Identity TID
forall (m :: * -> *). MonadC m => TID -> m TID
gensym TID
"chan"
  Definition -> CGen ()
forall (m :: * -> *). MonadC m => Definition -> m ()
addGlobal [cedecl| typename chan_t $id:c; |]
  Stm -> CGen ()
forall (m :: * -> *). MonadC m => Stm -> m ()
addStm [cstm| $id:c = chan_new($sz'); |]
  Chan t c -> CGenT Identity (Chan t c)
forall (m :: * -> *) a. Monad m => a -> m a
return Chan t c
c
compChanCMD cmd :: ChanCMD (Param3 CGen exp ct) a
cmd@(WriteOne Chan t c
c (exp a
x :: exp a)) = do
  Exp
x'         <- exp a -> CGenT Identity Exp
forall (exp :: * -> *) (m :: * -> *) a.
(CompExp exp, MonadC m) =>
exp a -> m Exp
compExp exp a
x
  Val a
v :: Val a <- Proxy ct -> CGenT Identity (Val a)
forall (m :: * -> *) (ct :: * -> Constraint)
       (proxy :: (* -> Constraint) -> *) a.
(MonadC m, CompTypeClass ct, ct a) =>
proxy ct -> m (Val a)
freshVar (ChanCMD (Param3 CGen exp ct) a -> Proxy ct
forall k1 k2 k3 k4 (cmd :: (k1, (k2, (k3, *))) -> k4 -> *)
       (p :: k1) (e :: k2) (pred :: k3) (a :: k4).
cmd (Param3 p e pred) a -> Proxy pred
proxyPred ChanCMD (Param3 CGen exp ct) a
cmd)
  Val Bool
ok         <- Proxy ct -> CGenT Identity (Val Bool)
forall (m :: * -> *) (ct :: * -> Constraint)
       (proxy :: (* -> Constraint) -> *) a.
(MonadC m, CompTypeClass ct, ct a) =>
proxy ct -> m (Val a)
freshVar (ChanCMD (Param3 CGen exp ct) a -> Proxy ct
forall k1 k2 k3 k4 (cmd :: (k1, (k2, (k3, *))) -> k4 -> *)
       (p :: k1) (e :: k2) (pred :: k3) (a :: k4).
cmd (Param3 p e pred) a -> Proxy pred
proxyPred ChanCMD (Param3 CGen exp ct) a
cmd)
  Stm -> CGen ()
forall (m :: * -> *). MonadC m => Stm -> m ()
addStm [cstm| $id:v = $x'; |]
  Stm -> CGen ()
forall (m :: * -> *). MonadC m => Stm -> m ()
addStm [cstm| $id:ok = chan_write($id:c, sizeof($id:v), &$id:v); |]
  Val Bool -> CGenT Identity (Val Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Val Bool
ok
compChanCMD cmd :: ChanCMD (Param3 CGen exp ct) a
cmd@(WriteChan Chan t c
c exp i
from exp i
to (ArrComp TID
arr)) = do
  Exp
from' <- exp i -> CGenT Identity Exp
forall (exp :: * -> *) (m :: * -> *) a.
(CompExp exp, MonadC m) =>
exp a -> m Exp
compExp exp i
from
  Exp
to' <- exp i -> CGenT Identity Exp
forall (exp :: * -> *) (m :: * -> *) a.
(CompExp exp, MonadC m) =>
exp a -> m Exp
compExp exp i
to
  Val Bool
ok <- Proxy ct -> CGenT Identity (Val Bool)
forall (m :: * -> *) (ct :: * -> Constraint)
       (proxy :: (* -> Constraint) -> *) a.
(MonadC m, CompTypeClass ct, ct a) =>
proxy ct -> m (Val a)
freshVar (ChanCMD (Param3 CGen exp ct) a -> Proxy ct
forall k1 k2 k3 k4 (cmd :: (k1, (k2, (k3, *))) -> k4 -> *)
       (p :: k1) (e :: k2) (pred :: k3) (a :: k4).
cmd (Param3 p e pred) a -> Proxy pred
proxyPred ChanCMD (Param3 CGen exp ct) a
cmd)
  Stm -> CGen ()
forall (m :: * -> *). MonadC m => Stm -> m ()
addStm [cstm| $id:ok = chan_write($id:c, sizeof(*$id:arr)*(($to')-($from')), &$id:arr[$from']); |]
  Val Bool -> CGenT Identity (Val Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Val Bool
ok
compChanCMD cmd :: ChanCMD (Param3 CGen exp ct) a
cmd@(ReadOne Chan t c
c) = do
  Val a
v <- Proxy ct -> CGenT Identity (Val a)
forall (m :: * -> *) (ct :: * -> Constraint)
       (proxy :: (* -> Constraint) -> *) a.
(MonadC m, CompTypeClass ct, ct a) =>
proxy ct -> m (Val a)
freshVar (ChanCMD (Param3 CGen exp ct) a -> Proxy ct
forall k1 k2 k3 k4 (cmd :: (k1, (k2, (k3, *))) -> k4 -> *)
       (p :: k1) (e :: k2) (pred :: k3) (a :: k4).
cmd (Param3 p e pred) a -> Proxy pred
proxyPred ChanCMD (Param3 CGen exp ct) a
cmd)
  Stm -> CGen ()
forall (m :: * -> *). MonadC m => Stm -> m ()
addStm [cstm| chan_read($id:c, sizeof($id:v), &$id:v); |]
  Val a -> CGenT Identity (Val a)
forall (m :: * -> *) a. Monad m => a -> m a
return Val a
v
compChanCMD cmd :: ChanCMD (Param3 CGen exp ct) a
cmd@(ReadChan Chan t c
c exp i
from exp i
to (ArrComp TID
arr)) = do
  Val Bool
ok <- Proxy ct -> CGenT Identity (Val Bool)
forall (m :: * -> *) (ct :: * -> Constraint)
       (proxy :: (* -> Constraint) -> *) a.
(MonadC m, CompTypeClass ct, ct a) =>
proxy ct -> m (Val a)
freshVar (ChanCMD (Param3 CGen exp ct) a -> Proxy ct
forall k1 k2 k3 k4 (cmd :: (k1, (k2, (k3, *))) -> k4 -> *)
       (p :: k1) (e :: k2) (pred :: k3) (a :: k4).
cmd (Param3 p e pred) a -> Proxy pred
proxyPred ChanCMD (Param3 CGen exp ct) a
cmd)
  Exp
from' <- exp i -> CGenT Identity Exp
forall (exp :: * -> *) (m :: * -> *) a.
(CompExp exp, MonadC m) =>
exp a -> m Exp
compExp exp i
from
  Exp
to' <- exp i -> CGenT Identity Exp
forall (exp :: * -> *) (m :: * -> *) a.
(CompExp exp, MonadC m) =>
exp a -> m Exp
compExp exp i
to
  Stm -> CGen ()
forall (m :: * -> *). MonadC m => Stm -> m ()
addStm [cstm| chan_read($id:c, sizeof(*$id:arr)*(($to')-($from')), &$id:arr[$from']); |]
  Stm -> CGen ()
forall (m :: * -> *). MonadC m => Stm -> m ()
addStm [cstm| $id:ok = chan_last_read_ok($id:c); |]
  Val Bool -> CGenT Identity (Val Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Val Bool
ok
compChanCMD (CloseChan Chan Closeable c
c) = do
  Stm -> CGen ()
forall (m :: * -> *). MonadC m => Stm -> m ()
addStm [cstm| chan_close($id:c); |]
compChanCMD cmd :: ChanCMD (Param3 CGen exp ct) a
cmd@(ReadOK Chan Closeable c
c) = do
  Val Bool
var <- Proxy ct -> CGenT Identity (Val Bool)
forall (m :: * -> *) (ct :: * -> Constraint)
       (proxy :: (* -> Constraint) -> *) a.
(MonadC m, CompTypeClass ct, ct a) =>
proxy ct -> m (Val a)
freshVar (ChanCMD (Param3 CGen exp ct) a -> Proxy ct
forall k1 k2 k3 k4 (cmd :: (k1, (k2, (k3, *))) -> k4 -> *)
       (p :: k1) (e :: k2) (pred :: k3) (a :: k4).
cmd (Param3 p e pred) a -> Proxy pred
proxyPred ChanCMD (Param3 CGen exp ct) a
cmd)
  Stm -> CGen ()
forall (m :: * -> *). MonadC m => Stm -> m ()
addStm [cstm| $id:var = chan_last_read_ok($id:c); |]
  Val Bool -> CGenT Identity (Val Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return Val Bool
var

compChanSize :: forall exp ct i. (CompExp exp, CompTypeClass ct) => ChanSize exp ct i -> CGen C.Exp
compChanSize :: ChanSize exp ct i -> CGenT Identity Exp
compChanSize (OneSize proxy a
t exp i
sz) = do
  Type
t' <- Proxy ct -> proxy a -> CGenT Identity Type
forall (ct :: * -> Constraint) a (m :: * -> *)
       (proxy1 :: (* -> Constraint) -> *) (proxy2 :: * -> *).
(CompTypeClass ct, ct a, MonadC m) =>
proxy1 ct -> proxy2 a -> m Type
compType (Proxy ct
forall k (t :: k). Proxy t
Proxy :: Proxy ct) proxy a
t
  Exp
sz' <- exp i -> CGenT Identity Exp
forall (exp :: * -> *) (m :: * -> *) a.
(CompExp exp, MonadC m) =>
exp a -> m Exp
compExp exp i
sz
  Exp -> CGenT Identity Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $sz' * sizeof($ty:t') |]
compChanSize (TimesSize exp i
n ChanSize exp ct i
sz) = do
  Exp
n' <- exp i -> CGenT Identity Exp
forall (exp :: * -> *) (m :: * -> *) a.
(CompExp exp, MonadC m) =>
exp a -> m Exp
compExp exp i
n
  Exp
sz' <- ChanSize exp ct i -> CGenT Identity Exp
forall (exp :: * -> *) (ct :: * -> Constraint) i.
(CompExp exp, CompTypeClass ct) =>
ChanSize exp ct i -> CGenT Identity Exp
compChanSize ChanSize exp ct i
sz
  Exp -> CGenT Identity Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $n' * $sz' |]
compChanSize (PlusSize ChanSize exp ct i
a ChanSize exp ct i
b) = do
  Exp
a' <- ChanSize exp ct i -> CGenT Identity Exp
forall (exp :: * -> *) (ct :: * -> Constraint) i.
(CompExp exp, CompTypeClass ct) =>
ChanSize exp ct i -> CGenT Identity Exp
compChanSize ChanSize exp ct i
a
  Exp
b' <- ChanSize exp ct i -> CGenT Identity Exp
forall (exp :: * -> *) (ct :: * -> Constraint) i.
(CompExp exp, CompTypeClass ct) =>
ChanSize exp ct i -> CGenT Identity Exp
compChanSize ChanSize exp ct i
b
  Exp -> CGenT Identity Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $a' + $b' |]

instance CompExp exp => Interp ThreadCMD CGen (Param2 exp pred) where
  interp :: ThreadCMD '(CGen, Param2 exp pred) a -> CGen a
interp = ThreadCMD '(CGen, Param2 exp pred) a -> CGen a
forall k2 (exp :: * -> *) (pred :: k2) a.
CompExp exp =>
ThreadCMD (Param3 CGen exp pred) a -> CGen a
compThreadCMD
instance (CompExp exp, CompTypeClass ct, ct Bool) => Interp ChanCMD CGen (Param2 exp ct) where
  interp :: ChanCMD '(CGen, Param2 exp ct) a -> CGen a
interp = ChanCMD '(CGen, Param2 exp ct) a -> CGen a
forall (exp :: * -> *) (ct :: * -> Constraint) a.
(CompExp exp, CompTypeClass ct, ct Bool) =>
ChanCMD (Param3 CGen exp ct) a -> CGen a
compChanCMD