{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{- | Translate SSM program to C compilation unit.

What is expected of the IR:

Well-formed: All primitive functions are applied to the right number of
arguments.

Pure par expression: All par-expressions' operands are applications that have no
side effects.

Defunctionalized: No lambdas; the only terms with an arrow type are variables
or applications.

Name mangled: All variable identifiers are unique.
-}
module Codegen.Codegen where

import Codegen.LibSSM
import Codegen.Typegen (
  DConInfo (..),
  TConInfo (..),
  TypegenInfo (..),
  genTypes,
 )

import qualified IR.IR as I
import qualified IR.Types as I

import Language.C.Quote.GCC
import qualified Language.C.Syntax as C

import qualified Common.Compiler as Compiler
import Common.Identifiers (fromId, fromString)

import Control.Monad (foldM, unless)
import Control.Monad.Except (MonadError (..))
import Control.Monad.State.Lazy (
  MonadState,
  StateT (..),
  evalStateT,
  gets,
  modify,
 )
import Data.Bifunctor (Bifunctor (..))
import qualified Data.Map as M
import Data.Maybe (mapMaybe)
import Prelude hiding (drop)

import GHC.Stack (HasCallStack)


-- | Possible, but temporarily punted for the sake of expediency.
todo :: HasCallStack => a
todo :: a
todo = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet implemented"


-- | Impossible without a discussion about implementation strategy.
nope :: HasCallStack => a
nope :: a
nope = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Not yet supported"


-- | Hack to allow us to splice string literals into C AST
newtype EscExp = EscExp String


instance ToExp EscExp where
  toExp :: EscExp -> SrcLoc -> Exp
toExp (EscExp [Char]
e) SrcLoc
loc = [Char] -> SrcLoc -> Exp
C.EscExp [Char]
e SrcLoc
loc


{- | State maintained while compiling a top-level SSM function.

The information here is populated while generating the step function, so that
should be computed first, before this information is used to generate the act
struct and enter definitions.
-}
data GenFnState = GenFnState
  { GenFnState -> VarId
fnName :: I.VarId
  -- ^ Function name
  , GenFnState -> [Binder Type]
fnParams :: [I.Binder I.Type]
  -- ^ Function parameters
  , GenFnState -> Type
fnRetTy :: I.Type
  -- ^ Function return type
  , GenFnState -> Expr Type
fnBody :: I.Expr I.Type
  -- ^ Function body
  , GenFnState -> Map VarId Type
fnLocals :: M.Map I.VarId I.Type
  -- ^ Function local variables
  , GenFnState -> Map VarId Exp
fnVars :: M.Map I.VarId C.Exp
  -- ^ How to resolve variables
  , GenFnState -> Int
fnMaxWaits :: Int
  -- ^ Number of triggers needed
  , GenFnState -> Int
fnCases :: Int
  -- ^ Yield point counter
  , GenFnState -> Int
fnFresh :: Int
  -- ^ Temporary variable name counter
  , GenFnState -> TypegenInfo
fnTypeInfo :: TypegenInfo
  -- ^ (User-defined) type information
  }


{- | Translation monad for procedures, with derived typeclass instances.

We declare 'GenFn' as a newtype so that we can implement 'MonadFail' for it,
allowing us to use monadic pattern matching.
-}
newtype GenFn a = GenFn (StateT GenFnState Compiler.Pass a)
  deriving (a -> GenFn b -> GenFn a
(a -> b) -> GenFn a -> GenFn b
(forall a b. (a -> b) -> GenFn a -> GenFn b)
-> (forall a b. a -> GenFn b -> GenFn a) -> Functor GenFn
forall a b. a -> GenFn b -> GenFn a
forall a b. (a -> b) -> GenFn a -> GenFn b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> GenFn b -> GenFn a
$c<$ :: forall a b. a -> GenFn b -> GenFn a
fmap :: (a -> b) -> GenFn a -> GenFn b
$cfmap :: forall a b. (a -> b) -> GenFn a -> GenFn b
Functor) via StateT GenFnState Compiler.Pass
  deriving (Functor GenFn
a -> GenFn a
Functor GenFn
-> (forall a. a -> GenFn a)
-> (forall a b. GenFn (a -> b) -> GenFn a -> GenFn b)
-> (forall a b c. (a -> b -> c) -> GenFn a -> GenFn b -> GenFn c)
-> (forall a b. GenFn a -> GenFn b -> GenFn b)
-> (forall a b. GenFn a -> GenFn b -> GenFn a)
-> Applicative GenFn
GenFn a -> GenFn b -> GenFn b
GenFn a -> GenFn b -> GenFn a
GenFn (a -> b) -> GenFn a -> GenFn b
(a -> b -> c) -> GenFn a -> GenFn b -> GenFn c
forall a. a -> GenFn a
forall a b. GenFn a -> GenFn b -> GenFn a
forall a b. GenFn a -> GenFn b -> GenFn b
forall a b. GenFn (a -> b) -> GenFn a -> GenFn b
forall a b c. (a -> b -> c) -> GenFn a -> GenFn b -> GenFn c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: GenFn a -> GenFn b -> GenFn a
$c<* :: forall a b. GenFn a -> GenFn b -> GenFn a
*> :: GenFn a -> GenFn b -> GenFn b
$c*> :: forall a b. GenFn a -> GenFn b -> GenFn b
liftA2 :: (a -> b -> c) -> GenFn a -> GenFn b -> GenFn c
$cliftA2 :: forall a b c. (a -> b -> c) -> GenFn a -> GenFn b -> GenFn c
<*> :: GenFn (a -> b) -> GenFn a -> GenFn b
$c<*> :: forall a b. GenFn (a -> b) -> GenFn a -> GenFn b
pure :: a -> GenFn a
$cpure :: forall a. a -> GenFn a
$cp1Applicative :: Functor GenFn
Applicative) via StateT GenFnState Compiler.Pass
  deriving (Applicative GenFn
a -> GenFn a
Applicative GenFn
-> (forall a b. GenFn a -> (a -> GenFn b) -> GenFn b)
-> (forall a b. GenFn a -> GenFn b -> GenFn b)
-> (forall a. a -> GenFn a)
-> Monad GenFn
GenFn a -> (a -> GenFn b) -> GenFn b
GenFn a -> GenFn b -> GenFn b
forall a. a -> GenFn a
forall a b. GenFn a -> GenFn b -> GenFn b
forall a b. GenFn a -> (a -> GenFn b) -> GenFn b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> GenFn a
$creturn :: forall a. a -> GenFn a
>> :: GenFn a -> GenFn b -> GenFn b
$c>> :: forall a b. GenFn a -> GenFn b -> GenFn b
>>= :: GenFn a -> (a -> GenFn b) -> GenFn b
$c>>= :: forall a b. GenFn a -> (a -> GenFn b) -> GenFn b
$cp1Monad :: Applicative GenFn
Monad) via StateT GenFnState Compiler.Pass
  deriving (Monad GenFn
Monad GenFn -> (forall a. [Char] -> GenFn a) -> MonadFail GenFn
[Char] -> GenFn a
forall a. [Char] -> GenFn a
forall (m :: * -> *).
Monad m -> (forall a. [Char] -> m a) -> MonadFail m
fail :: [Char] -> GenFn a
$cfail :: forall a. [Char] -> GenFn a
$cp1MonadFail :: Monad GenFn
MonadFail) via StateT GenFnState Compiler.Pass
  deriving (MonadError Compiler.Error) via StateT GenFnState Compiler.Pass
  deriving (MonadState GenFnState) via StateT GenFnState Compiler.Pass
  deriving (Compiler.MonadWriter [Compiler.Warning]) via StateT GenFnState Compiler.Pass


-- | Run a 'GenFn' computation on a procedure.
runGenFn
  :: I.VarId
  -- ^ Name of procedure
  -> [I.Binder I.Type]
  -- ^ Names and types of parameters to procedure
  -> I.Expr I.Type
  -- ^ Body of procedure
  -> TypegenInfo
  -- ^ Type information
  -> [(I.VarId, I.Type)]
  -- ^ Other global identifiers
  -> GenFn a
  -- ^ Translation monad to run
  -> Compiler.Pass a
  -- ^ Pass on errors to caller
runGenFn :: VarId
-> [Binder Type]
-> Expr Type
-> TypegenInfo
-> [(VarId, Type)]
-> GenFn a
-> Pass a
runGenFn VarId
name [Binder Type]
params Expr Type
body TypegenInfo
typeInfo [(VarId, Type)]
globals (GenFn StateT GenFnState Pass a
tra) =
  StateT GenFnState Pass a -> GenFnState -> Pass a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT GenFnState Pass a
tra (GenFnState -> Pass a) -> GenFnState -> Pass a
forall a b. (a -> b) -> a -> b
$
    GenFnState :: VarId
-> [Binder Type]
-> Type
-> Expr Type
-> Map VarId Type
-> Map VarId Exp
-> Int
-> Int
-> Int
-> TypegenInfo
-> GenFnState
GenFnState
      { fnName :: VarId
fnName = VarId
name
      , fnParams :: [Binder Type]
fnParams = [Binder Type]
params
      , fnRetTy :: Type
fnRetTy = Expr Type -> Type
forall (c :: * -> *) a. Carrier c => c a -> a
I.extract Expr Type
body
      , fnBody :: Expr Type
fnBody = Expr Type
body
      , fnLocals :: Map VarId Type
fnLocals = Map VarId Type
forall k a. Map k a
M.empty
      , fnVars :: Map VarId Exp
fnVars =
          [(VarId, Exp)] -> Map VarId Exp
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(VarId, Exp)] -> Map VarId Exp)
-> [(VarId, Exp)] -> Map VarId Exp
forall a b. (a -> b) -> a -> b
$ (Binder Type -> Maybe (VarId, Exp))
-> [Binder Type] -> [(VarId, Exp)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Binder Type -> Maybe (VarId, Exp)
resolveParam [Binder Type]
params [(VarId, Exp)] -> [(VarId, Exp)] -> [(VarId, Exp)]
forall a. [a] -> [a] -> [a]
++ ((VarId, Type) -> (VarId, Exp))
-> [(VarId, Type)] -> [(VarId, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map (VarId, Type) -> (VarId, Exp)
genGlobal [(VarId, Type)]
globals
      , fnTypeInfo :: TypegenInfo
fnTypeInfo = TypegenInfo
typeInfo
      , fnMaxWaits :: Int
fnMaxWaits = Int
0
      , fnCases :: Int
fnCases = Int
0
      , fnFresh :: Int
fnFresh = Int
0
      }
 where
  resolveParam :: I.Binder I.Type -> Maybe (I.VarId, C.Exp)
  resolveParam :: Binder Type -> Maybe (VarId, Exp)
resolveParam (I.BindVar VarId
v Type
_) = (VarId, Exp) -> Maybe (VarId, Exp)
forall a. a -> Maybe a
Just (VarId
v, CIdent -> Exp
acts_ (CIdent -> Exp) -> CIdent -> Exp
forall a b. (a -> b) -> a -> b
$ VarId -> CIdent
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId VarId
v)
  resolveParam Binder Type
_ = Maybe (VarId, Exp)
forall a. Maybe a
Nothing

  genGlobal :: (I.VarId, I.Type) -> (I.VarId, C.Exp)
  genGlobal :: (VarId, Type) -> (VarId, Exp)
genGlobal (VarId
v, I.Arrow Type
_ Type
_) = (VarId
v, CIdent -> Exp
static_value (CIdent -> Exp) -> CIdent -> Exp
forall a b. (a -> b) -> a -> b
$ VarId -> CIdent
closure_ VarId
v)
  genGlobal (VarId, Type)
_ = (VarId, Exp)
forall a. HasCallStack => a
todo


-- | Lookup some information associated with a type constructor.
getsTCon :: (TConInfo -> a) -> I.TConId -> GenFn a
getsTCon :: (TConInfo -> a) -> TConId -> GenFn a
getsTCon TConInfo -> a
f TConId
i = do
  Just a
a <- (TConInfo -> a) -> Maybe TConInfo -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TConInfo -> a
f (Maybe TConInfo -> Maybe a)
-> (TypegenInfo -> Maybe TConInfo) -> TypegenInfo -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypegenInfo -> TConId -> Maybe TConInfo
`tconInfo` TConId
i) (TypegenInfo -> Maybe a) -> GenFn TypegenInfo -> GenFn (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenFnState -> TypegenInfo) -> GenFn TypegenInfo
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> TypegenInfo
fnTypeInfo
  a -> GenFn a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


-- | Lookup some information associated with a data constructor.
getsDCon :: (DConInfo -> a) -> I.DConId -> GenFn a
getsDCon :: (DConInfo -> a) -> DConId -> GenFn a
getsDCon DConInfo -> a
f DConId
i = do
  Just a
a <- (DConInfo -> a) -> Maybe DConInfo -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DConInfo -> a
f (Maybe DConInfo -> Maybe a)
-> (TypegenInfo -> Maybe DConInfo) -> TypegenInfo -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypegenInfo -> DConId -> Maybe DConInfo
`dconInfo` DConId
i) (TypegenInfo -> Maybe a) -> GenFn TypegenInfo -> GenFn (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenFnState -> TypegenInfo) -> GenFn TypegenInfo
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> TypegenInfo
fnTypeInfo
  a -> GenFn a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


-- | Read and increment the number of cases in a procedure, i.e., @fnCases++@.
nextCase :: GenFn Int
nextCase :: GenFn Int
nextCase = do
  Int
n <- (GenFnState -> Int) -> GenFn Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> Int
fnCases
  (GenFnState -> GenFnState) -> GenFn ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((GenFnState -> GenFnState) -> GenFn ())
-> (GenFnState -> GenFnState) -> GenFn ()
forall a b. (a -> b) -> a -> b
$ \GenFnState
st -> GenFnState
st{fnCases :: Int
fnCases = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}
  Int -> GenFn Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n


-- | Obtain fresh integer in the 'GenFn' monad
getFresh :: GenFn Int
getFresh :: GenFn Int
getFresh = do
  Int
n <- (GenFnState -> Int) -> GenFn Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> Int
fnFresh
  (GenFnState -> GenFnState) -> GenFn ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((GenFnState -> GenFnState) -> GenFn ())
-> (GenFnState -> GenFnState) -> GenFn ()
forall a b. (a -> b) -> a -> b
$ \GenFnState
st -> GenFnState
st{fnFresh :: Int
fnFresh = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}
  Int -> GenFn Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
n


-- | Bind a variable to a C expression.
addBinding :: I.Binder I.Type -> C.Exp -> GenFn ()
addBinding :: Binder Type -> Exp -> GenFn ()
addBinding (I.BindVar VarId
v Type
_) Exp
e =
  (GenFnState -> GenFnState) -> GenFn ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((GenFnState -> GenFnState) -> GenFn ())
-> (GenFnState -> GenFnState) -> GenFn ()
forall a b. (a -> b) -> a -> b
$ \GenFnState
st -> GenFnState
st{fnVars :: Map VarId Exp
fnVars = VarId -> Exp -> Map VarId Exp -> Map VarId Exp
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VarId
v Exp
e (Map VarId Exp -> Map VarId Exp) -> Map VarId Exp -> Map VarId Exp
forall a b. (a -> b) -> a -> b
$ GenFnState -> Map VarId Exp
fnVars GenFnState
st}
addBinding Binder Type
_ Exp
_ = () -> GenFn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | Register a new local variable, to be declared in activation record.
addLocal :: I.VarId -> I.Type -> GenFn I.VarId
addLocal :: VarId -> Type -> GenFn VarId
addLocal VarId
v Type
t = do
  Map VarId Type
fnl <- (GenFnState -> Map VarId Type) -> GenFn (Map VarId Type)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> Map VarId Type
fnLocals
  VarId
v' <-
    if VarId
v VarId -> Map VarId Type -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map VarId Type
fnl
      then do
        Int
ctr <- GenFn Int
getFresh
        VarId -> GenFn VarId
forall (m :: * -> *) a. Monad m => a -> m a
return (VarId -> GenFn VarId) -> VarId -> GenFn VarId
forall a b. (a -> b) -> a -> b
$ VarId
v VarId -> VarId -> VarId
forall a. Semigroup a => a -> a -> a
<> [Char] -> VarId
forall a. IsString a => [Char] -> a
fromString (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
ctr)
      else VarId -> GenFn VarId
forall (m :: * -> *) a. Monad m => a -> m a
return VarId
v
  (GenFnState -> GenFnState) -> GenFn ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((GenFnState -> GenFnState) -> GenFn ())
-> (GenFnState -> GenFnState) -> GenFn ()
forall a b. (a -> b) -> a -> b
$ \GenFnState
st -> GenFnState
st{fnLocals :: Map VarId Type
fnLocals = VarId -> Type -> Map VarId Type -> Map VarId Type
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert VarId
v' Type
t Map VarId Type
fnl}
  VarId -> GenFn VarId
forall (m :: * -> *) a. Monad m => a -> m a
return VarId
v'


-- | Bind a variable to a C expression only while computing the given monad.
withBindings :: [(I.Binder I.Type, C.Exp)] -> GenFn a -> GenFn a
withBindings :: [(Binder Type, Exp)] -> GenFn a -> GenFn a
withBindings [(Binder Type, Exp)]
bs GenFn a
m = do
  Map VarId Exp
fnv <- (GenFnState -> Map VarId Exp) -> GenFn (Map VarId Exp)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> Map VarId Exp
fnVars
  ((Binder Type, Exp) -> GenFn ())
-> [(Binder Type, Exp)] -> GenFn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Binder Type -> Exp -> GenFn ()) -> (Binder Type, Exp) -> GenFn ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Binder Type -> Exp -> GenFn ()
addBinding) [(Binder Type, Exp)]
bs
  a
a <- GenFn a
m
  (GenFnState -> GenFnState) -> GenFn ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((GenFnState -> GenFnState) -> GenFn ())
-> (GenFnState -> GenFnState) -> GenFn ()
forall a b. (a -> b) -> a -> b
$ \GenFnState
st -> GenFnState
st{fnVars :: Map VarId Exp
fnVars = Map VarId Exp
fnv}
  a -> GenFn a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


-- | Register a local variable and bind its C expression during a monad.
withNewLocal :: (I.VarId, I.Type) -> GenFn a -> GenFn a
withNewLocal :: (VarId, Type) -> GenFn a -> GenFn a
withNewLocal (VarId
v, Type
t) GenFn a
m = do
  VarId
v' <- VarId -> Type -> GenFn VarId
addLocal VarId
v Type
t
  [(Binder Type, Exp)] -> GenFn a -> GenFn a
forall a. [(Binder Type, Exp)] -> GenFn a -> GenFn a
withBindings [(VarId -> Type -> Binder Type
forall t. VarId -> t -> Binder t
I.BindVar VarId
v Type
t, CIdent -> Exp
acts_ (CIdent -> Exp) -> CIdent -> Exp
forall a b. (a -> b) -> a -> b
$ VarId -> CIdent
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId VarId
v')] GenFn a
m


-- | Register number of wait statements track of number of triggers needed.
maxWait :: Int -> GenFn ()
maxWait :: Int -> GenFn ()
maxWait Int
n = (GenFnState -> GenFnState) -> GenFn ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((GenFnState -> GenFnState) -> GenFn ())
-> (GenFnState -> GenFnState) -> GenFn ()
forall a b. (a -> b) -> a -> b
$ \GenFnState
st -> GenFnState
st{fnMaxWaits :: Int
fnMaxWaits = Int
n Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` GenFnState -> Int
fnMaxWaits GenFnState
st}


-- | Generate a fresh label.
freshLabel :: GenFn CIdent
freshLabel :: GenFn CIdent
freshLabel = CIdent -> CIdent
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId (CIdent -> CIdent) -> (Int -> CIdent) -> Int -> CIdent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> CIdent
label_ (Int -> CIdent) -> GenFn Int -> GenFn CIdent
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenFn Int
getFresh


-- | Generate anonymous local variable in activation record for storage.
genTmp :: I.Type -> GenFn C.Exp
genTmp :: Type -> GenFn Exp
genTmp Type
ty = do
  VarId
v <- CIdent -> VarId
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId (CIdent -> VarId) -> (Int -> CIdent) -> Int -> VarId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> CIdent
tmp_ (Int -> VarId) -> GenFn Int -> GenFn VarId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenFn Int
getFresh
  VarId
v' <- VarId -> Type -> GenFn VarId
addLocal VarId
v Type
ty
  Exp -> GenFn Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> GenFn Exp) -> Exp -> GenFn Exp
forall a b. (a -> b) -> a -> b
$ CIdent -> Exp
acts_ (CIdent -> Exp) -> CIdent -> Exp
forall a b. (a -> b) -> a -> b
$ VarId -> CIdent
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId VarId
v'


-- | Translate a list of SSM parameters to C parameters.
genParams :: [I.Binder I.Type] -> [(CIdent, C.Type)]
genParams :: [Binder Type] -> [(CIdent, Type)]
genParams = (Int -> Binder Type -> (CIdent, Type))
-> [Int] -> [Binder Type] -> [(CIdent, Type)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Binder Type -> (CIdent, Type)
forall t. Int -> Binder t -> (CIdent, Type)
genArg [Int
0 ..]
 where
  genArg :: Int -> Binder t -> (CIdent, Type)
genArg Int
_ (I.BindVar VarId
v t
_) = (VarId -> CIdent
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId VarId
v, Type
value_t)
  genArg Int
i Binder t
_ = (Int -> CIdent
arg_ Int
i, Type
value_t)


-- | Translate a list of SSM local declarations to C declarations.
genLocals :: [(I.VarId, I.Type)] -> [(CIdent, C.Type)]
genLocals :: [(VarId, Type)] -> [(CIdent, Type)]
genLocals = ((VarId, Type) -> (CIdent, Type))
-> [(VarId, Type)] -> [(CIdent, Type)]
forall a b. (a -> b) -> [a] -> [b]
map (((VarId, Type) -> (CIdent, Type))
 -> [(VarId, Type)] -> [(CIdent, Type)])
-> ((VarId, Type) -> (CIdent, Type))
-> [(VarId, Type)]
-> [(CIdent, Type)]
forall a b. (a -> b) -> a -> b
$ (VarId -> CIdent)
-> (Type -> Type) -> (VarId, Type) -> (CIdent, Type)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap VarId -> CIdent
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId (Type -> Type -> Type
forall a b. a -> b -> a
const Type
value_t)


-- | Generate declarations for @numTrigs@ triggers.
genTrigs :: Int -> [(CIdent, C.Type)]
genTrigs :: Int -> [(CIdent, Type)]
genTrigs Int
numTrigs = [CIdent] -> [Type] -> [(CIdent, Type)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Int -> CIdent) -> [Int] -> [CIdent]
forall a b. (a -> b) -> [a] -> [b]
map Int -> CIdent
trig_ [Int
1 .. Int
numTrigs]) (Type -> [Type]
forall a. a -> [a]
repeat Type
trigger_t)


-- | The constant unit value, the singleton inhabitant of the type Unit.
unit :: C.Exp
unit :: Exp
unit = Exp -> Exp
marshal [cexp|0|]


-- | Fake undefined value used for expressions of type Void.
undef :: C.Exp
undef :: Exp
undef = Exp -> Exp
marshal [cexp|0xdeadbeef|]


{-------- Compilation --------}

{- | Generate a C compilation from an SSM program.

 Each top-level function in a program is turned into three components:

 1. a struct (the activation record);
 2. an initialization function (the enter function); and
 3. a step function, which corresponds to the actual procedure body.

 Items 2 and 3 include both declarations and definitions.
-}
genProgram :: I.Program I.Type -> Compiler.Pass [C.Definition]
genProgram :: Program Type -> Pass [Definition]
genProgram Program Type
p = do
  ([Definition]
tdefs, TypegenInfo
tinfo) <- [(TConId, TypeDef)] -> Pass ([Definition], TypegenInfo)
genTypes ([(TConId, TypeDef)] -> Pass ([Definition], TypegenInfo))
-> [(TConId, TypeDef)] -> Pass ([Definition], TypegenInfo)
forall a b. (a -> b) -> a -> b
$ Program Type -> [(TConId, TypeDef)]
forall t. Program t -> [(TConId, TypeDef)]
I.typeDefs Program Type
p
  ([Definition]
cdecls, [Definition]
cdefns) <- [([Definition], [Definition])] -> ([Definition], [Definition])
forall a a. [([a], [a])] -> ([a], [a])
cUnpack ([([Definition], [Definition])] -> ([Definition], [Definition]))
-> Pass [([Definition], [Definition])]
-> Pass ([Definition], [Definition])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Binder Type, Expr Type) -> Pass ([Definition], [Definition]))
-> [(Binder Type, Expr Type)]
-> Pass [([Definition], [Definition])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TypegenInfo
-> (Binder Type, Expr Type) -> Pass ([Definition], [Definition])
genTop TypegenInfo
tinfo) (Program Type -> [(Binder Type, Expr Type)]
forall t. Program t -> [(Binder t, Expr t)]
I.programDefs Program Type
p)
  [Definition]
externs <- ((VarId, Type) -> Pass Definition)
-> [(VarId, Type)] -> Pass [Definition]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (VarId, Type) -> Pass Definition
genExtern ([(VarId, Type)] -> Pass [Definition])
-> [(VarId, Type)] -> Pass [Definition]
forall a b. (a -> b) -> a -> b
$ Program Type -> [(VarId, Type)]
forall t. Program t -> [(VarId, Type)]
I.externDecls Program Type
p
  [Definition] -> Pass [Definition]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Definition] -> Pass [Definition])
-> [Definition] -> Pass [Definition]
forall a b. (a -> b) -> a -> b
$
    [Definition]
includes
      [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [Definition]
tdefs
      [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [Definition]
externs
      [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [Definition]
cescs
      [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [Definition]
cdecls
      [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [Definition]
cdefns
      [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ VarId -> [Definition]
genInitProgram (Program Type -> VarId
forall t. Program t -> VarId
I.programEntry Program Type
p)
 where
  genTop
    :: TypegenInfo
    -> (I.Binder I.Type, I.Expr I.Type)
    -> Compiler.Pass ([C.Definition], [C.Definition])
  genTop :: TypegenInfo
-> (Binder Type, Expr Type) -> Pass ([Definition], [Definition])
genTop TypegenInfo
tinfo (I.BindVar VarId
name Type
_, l :: Expr Type
l@I.Lambda{}) =
    VarId
-> [Binder Type]
-> Expr Type
-> TypegenInfo
-> [(VarId, Type)]
-> GenFn ([Definition], [Definition])
-> Pass ([Definition], [Definition])
forall a.
VarId
-> [Binder Type]
-> Expr Type
-> TypegenInfo
-> [(VarId, Type)]
-> GenFn a
-> Pass a
runGenFn (VarId -> VarId
forall a b. (Identifiable a, Identifiable b) => a -> b
fromId VarId
name) [Binder Type]
argIds Expr Type
body TypegenInfo
tinfo [(VarId, Type)]
tops (GenFn ([Definition], [Definition])
 -> Pass ([Definition], [Definition]))
-> GenFn ([Definition], [Definition])
-> Pass ([Definition], [Definition])
forall a b. (a -> b) -> a -> b
$ do
      (Definition
stepDecl, Definition
stepDefn) <- GenFn (Definition, Definition)
genStep
      (Definition
enterDecl, Definition
enterDefn) <- GenFn (Definition, Definition)
genEnter
      (Definition
closureDecl, Definition
closureDefn) <- GenFn (Definition, Definition)
genStaticClosure
      Definition
structDefn <- GenFn Definition
genStruct
      ([Definition], [Definition]) -> GenFn ([Definition], [Definition])
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( [Definition
structDefn, Definition
enterDecl, Definition
closureDecl, Definition
stepDecl]
        , [Definition
enterDefn, Definition
closureDefn, Definition
stepDefn]
        )
   where
    tops :: [(VarId, Type)]
tops = ((Binder Type, Expr Type) -> Maybe (VarId, Type))
-> [(Binder Type, Expr Type)] -> [(VarId, Type)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Binder Type, Expr Type) -> Maybe (VarId, Type)
forall (c :: * -> *) a b.
Carrier c =>
(Binder a, c b) -> Maybe (VarId, b)
extractBindVar ([(Binder Type, Expr Type)] -> [(VarId, Type)])
-> [(Binder Type, Expr Type)] -> [(VarId, Type)]
forall a b. (a -> b) -> a -> b
$ Program Type -> [(Binder Type, Expr Type)]
forall t. Program t -> [(Binder t, Expr t)]
I.programDefs Program Type
p
    extractBindVar :: (Binder a, c b) -> Maybe (VarId, b)
extractBindVar (Binder a -> Maybe VarId
forall a. Binder a -> Maybe VarId
I.binderToVar -> Just VarId
v, c b
e) = (VarId, b) -> Maybe (VarId, b)
forall a. a -> Maybe a
Just (VarId
v, c b -> b
forall (c :: * -> *) a. Carrier c => c a -> a
I.extract c b
e)
    extractBindVar (Binder a, c b)
_ = Maybe (VarId, b)
forall a. Maybe a
Nothing
    ([Binder Type]
argIds, Expr Type
body) = Expr Type -> ([Binder Type], Expr Type)
forall t. Expr t -> ([Binder t], Expr t)
I.unfoldLambda Expr Type
l
  genTop TypegenInfo
_ (Binder Type
_, I.Lit Literal
_ Type
_) = Pass ([Definition], [Definition])
forall a. HasCallStack => a
todo
  genTop TypegenInfo
_ (Binder Type
_, Expr Type
_) = Pass ([Definition], [Definition])
forall a. HasCallStack => a
nope

  cUnpack :: [([a], [a])] -> ([a], [a])
cUnpack = ([[a]] -> [a]) -> ([[a]] -> [a]) -> ([[a]], [[a]]) -> ([a], [a])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([[a]], [[a]]) -> ([a], [a]))
-> ([([a], [a])] -> ([[a]], [[a]])) -> [([a], [a])] -> ([a], [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([a], [a])] -> ([[a]], [[a]])
forall a b. [(a, b)] -> ([a], [b])
unzip
  cescs :: [Definition]
cescs = [cunit|$esc:(I.cDefs p)|]


-- | Include statements in the generated C file.
includes :: [C.Definition]
includes :: [Definition]
includes =
  [cunit|
$esc:("#include \"ssm.h\"")
typedef char unit;
|]


-- | Setup the entry point of the program.
genInitProgram :: I.VarId -> [C.Definition]
genInitProgram :: VarId -> [Definition]
genInitProgram = [Definition] -> VarId -> [Definition]
forall a b. a -> b -> a
const []


-- genInitProgram entry = [cunit|
--     $ty:act_t *$id:stdout_handler_enter($ty:act_t *parent,
--                                         $ty:priority_t priority,
--                                         $ty:depth_t depth,
--                                         $ty:value_t *argv,
--                                         $ty:value_t *ret);
--
--     void $id:stdin_handler_spawn($ty:sv_t *ssm_stdin);
--     void $id:stdin_handler_kill(void);
--
--     void $id:program_init(void) {
--       $ty:value_t ssm_stdin = $exp:std_sv;
--       $ty:value_t ssm_stdout = $exp:std_sv;
--
--       $ty:value_t std_argv[2] = { ssm_stdin, ssm_stdout };
--
--       $exp:(activate enter_stdout);
--       $exp:(activate enter_entry);
--
--       $id:stdin_handler_spawn($exp:(to_sv $ cexpr "ssm_stdin"));
--     }
--
--     void $id:program_exit(void) {
--       $id:stdin_handler_kill();
--     }
--   |]
--  where
--   std_sv                    = new_sv $ marshal [cexp|0|]
--
--   parArgs                   = genParArgs 2 (root_priority, root_depth)
--   (stdoutPrio, stdoutDepth) = head parArgs
--   (entryPrio , entryDepth ) = parArgs !! 1
--   enter_stdout = [cexp|$id:stdout_handler_enter(&$exp:top_parent,
--                                                 $exp:stdoutPrio,
--                                                 $exp:stdoutDepth,
--                                                 &ssm_stdout,
--                                                 NULL)|]
--
--   enter_entry = [cexp|$id:(enter_ entry)(&$exp:top_parent,
--                                          $exp:entryPrio,
--                                          $exp:entryDepth,
--                                          std_argv,
--                                          NULL)|]

genExtern :: (I.VarId, I.Type) -> Compiler.Pass C.Definition
genExtern :: (VarId, Type) -> Pass Definition
genExtern (VarId
v, Type
t) =
  Definition -> Pass Definition
forall (m :: * -> *) a. Monad m => a -> m a
return
    [cedecl|
    extern $ty:value_t $id:v($params:xparams);
  |]
 where
  argNum :: Int
argNum = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Type] -> Int) -> [Type] -> Int
forall a b. (a -> b) -> a -> b
$ ([Type], Type) -> [Type]
forall a b. (a, b) -> a
fst (([Type], Type) -> [Type]) -> ([Type], Type) -> [Type]
forall a b. (a -> b) -> a -> b
$ Type -> ([Type], Type)
I.unfoldArrow Type
t
  xparams :: [Param]
xparams = Int -> Param -> [Param]
forall a. Int -> a -> [a]
replicate Int
argNum [cparam|$ty:value_t|]


{- | Generate struct definition for an SSM procedure.

 This is where local variables, triggers, and parameter values are stored.
-}
genStruct :: GenFn C.Definition
genStruct :: GenFn Definition
genStruct = do
  VarId
name <- (GenFnState -> VarId) -> GenFn VarId
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> VarId
fnName
  [Binder Type]
params <- (GenFnState -> [Binder Type]) -> GenFn [Binder Type]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> [Binder Type]
fnParams
  -- retTy  <- gets fnRetTy
  [(VarId, Type)]
locs <- Map VarId Type -> [(VarId, Type)]
forall k a. Map k a -> [(k, a)]
M.toList (Map VarId Type -> [(VarId, Type)])
-> GenFn (Map VarId Type) -> GenFn [(VarId, Type)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenFnState -> Map VarId Type) -> GenFn (Map VarId Type)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> Map VarId Type
fnLocals
  Int
trigs <- (GenFnState -> Int) -> GenFn Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> Int
fnMaxWaits

  Definition -> GenFn Definition
forall (m :: * -> *) a. Monad m => a -> m a
return
    [cedecl|
    typedef struct {
      $ty:act_t $id:act_member;

      $sdecls:(map structField $ genParams params)
      $ty:value_t *$id:ret_val;
      $sdecls:(map structField $ genLocals locs)
      $sdecls:(map structField $ genTrigs trigs)

    } $id:(act_typename name);
  |]
 where
  structField :: (CIdent, C.Type) -> C.FieldGroup
  structField :: (CIdent, Type) -> FieldGroup
structField (CIdent
n, Type
t) = [csdecl|$ty:t $id:n;|]


{- | Generate the enter function for an SSM procedure and its signature.

 Its struct is allocated and initialized (partially; local variables' values are
 left uninitialized).
-}
genEnter :: GenFn (C.Definition, C.Definition)
genEnter :: GenFn (Definition, Definition)
genEnter = do
  VarId
actName <- (GenFnState -> VarId) -> GenFn VarId
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> VarId
fnName
  [Binder Type]
params <- (GenFnState -> [Binder Type]) -> GenFn [Binder Type]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> [Binder Type]
fnParams
  Int
trigs <- (GenFnState -> Int) -> GenFn Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> Int
fnMaxWaits
  let act :: Type
act = VarId -> Type
act_ VarId
actName
      enterParams :: [Param]
enterParams =
        [ [cparam|$ty:act_t *$id:enter_caller|]
        , [cparam|$ty:priority_t $id:enter_priority|]
        , [cparam|$ty:depth_t $id:enter_depth|]
        , [cparam|$ty:value_t *$id:argv|]
        , [cparam|$ty:value_t *$id:ret_val|]
        ]
      alloc_act :: Exp
alloc_act =
        Exp -> Exp -> Exp -> Exp -> Exp -> Exp
enter
          [cexp|sizeof($ty:act)|]
          [cexp|$id:(step_ actName)|]
          [cexp|$id:enter_caller|]
          [cexp|$id:enter_priority|]
          [cexp|$id:enter_depth|]
      get_acts :: Exp
get_acts = Exp -> VarId -> Exp
to_act (CIdent -> Exp
cexpr CIdent
actg) VarId
actName

      initParam :: (CIdent, b) -> Int -> C.Stm
      initParam :: (CIdent, b) -> Int -> Stm
initParam (CIdent
n, b
_) Int
i = [cstm|$id:acts->$id:n = $id:argv[$int:i];|]

      initTrig :: (CIdent, b) -> C.Stm
      initTrig :: (CIdent, b) -> Stm
initTrig (CIdent
trigId, b
_) = [cstm|$id:acts->$id:trigId.act = $id:actg;|]
  (Definition, Definition) -> GenFn (Definition, Definition)
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( [cedecl|$ty:act_t *$id:(enter_ actName)($params:enterParams);|]
    , [cedecl|
        $ty:act_t *$id:(enter_ actName)($params:enterParams) {
          $ty:act_t *$id:actg = $exp:alloc_act;
          $ty:act *$id:acts = $exp:get_acts;

          /* Assign parameters */
          $stms:(zipWith initParam (genParams params) [0..])

          /* Set return value */
          $id:acts->$id:ret_val = $id:ret_val;

          /* Initialize triggers */
          $stms:(map initTrig $ genTrigs trigs)

          return $id:actg;
        }
      |]
    )


-- | Generate static closure for top-level function
genStaticClosure :: GenFn (C.Definition, C.Definition)
genStaticClosure :: GenFn (Definition, Definition)
genStaticClosure = do
  VarId
actName <- (GenFnState -> VarId) -> GenFn VarId
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> VarId
fnName
  Int
argc <- [Binder Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Binder Type] -> Int) -> GenFn [Binder Type] -> GenFn Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenFnState -> [Binder Type]) -> GenFn [Binder Type]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> [Binder Type]
fnParams
  let closure_name :: CIdent
closure_name = VarId -> CIdent
closure_ VarId
actName
      enter_f :: Exp
enter_f = [cexp|$id:(enter_ actName)|]
  (Definition, Definition) -> GenFn (Definition, Definition)
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( [cedecl|extern $ty:closure1_t $id:closure_name;|]
    , [cedecl|$ty:closure1_t $id:closure_name = $init:(static_closure enter_f argc);|]
    )


{- | Generate the step function for an SSM procedure.

 This function just defines the function definition and switch statement that
 wraps the statements of the procedure. The heavy lifting is performed by
 'genExpr'.
-}
genStep :: GenFn (C.Definition, C.Definition)
genStep :: GenFn (Definition, Definition)
genStep = do
  VarId
actName <- (GenFnState -> VarId) -> GenFn VarId
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> VarId
fnName
  Expr Type
actBody <- (GenFnState -> Expr Type) -> GenFn (Expr Type)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> Expr Type
fnBody
  Int
firstCase <- GenFn Int
nextCase
  (Exp
ret_expr, [BlockItem]
stms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
actBody -- Toss away return value
  let act :: Type
act = VarId -> Type
act_ VarId
actName
      get_acts :: Exp
get_acts = Exp -> VarId -> Exp
to_act (CIdent -> Exp
cexpr CIdent
actg) VarId
actName
      do_leave :: Exp
do_leave = Exp -> Exp -> Exp
leave (CIdent -> Exp
cexpr CIdent
actg) (Type -> Exp
csizeof Type
act)
  (Definition, Definition) -> GenFn (Definition, Definition)
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( [cedecl|void $id:(step_ actName)($ty:act_t *$id:actg);|]
    , [cedecl|
        void $id:(step_ actName)($ty:act_t *$id:actg) {
          $ty:act *$id:acts = $exp:get_acts;

          switch ($id:actg->$id:act_pc) {
          case $int:firstCase:;
            $items:stms

          default:
            break;
          }
        if ($id:acts->$id:ret_val)
          *$id:acts->$id:ret_val = $exp:ret_expr;
        $exp:do_leave;
        }
      |]
    )


-- | Helper to generate yield point in step function.
genYield :: GenFn [C.BlockItem]
genYield :: GenFn [BlockItem]
genYield = do
  Int
next <- GenFn Int
nextCase
  [BlockItem] -> GenFn [BlockItem]
forall (m :: * -> *) a. Monad m => a -> m a
return
    [citems|
    $id:actg->$id:act_pc = $int:next;
    return;
    case $int:next:;
    |]


{- | Translate an SSM expression into a C expression and statements.

 SSM IR is a side-effectful expression language, with two implications when
 translating to C:

 1.  every expression has a value (even if it is an uninhabited type), so this
    must be reflected in C; and
 2.  some of the side effects in SSM cannot be implemented in C using expressions
    alone.

 These two implications roughly translate to the @C.Exp@ and @[C.BlockItem]@ in
 @genExpr@'s return type. When we translate an SSM expression @e@:

 > (val, stms) <- genExpr e

 @val@ represents the C expression that corresponds to the value of @e@ upon
 evaluation, while @stms@ represents the list of preceding statements that
 compute @val@.

 A further consideration upon point 2 is that SSM expressions may yield control
 at any point. Thus, the C expression returned by @genExpr@ must accommodate the
 step function suspending and resuming. For instance, consider the following SSM
 IR expression:

 > (let x = 3 in x) + (wait r; 6)

 The @x@ in the let-binding in the left operand cannot just be a local variable
 in the step function, because it would be "uninitialized" by the yield in the
 right operand:

 >   // let x = 3 in x
 >   // stms:
 >   int x = 3;
 >   // exp: x
 >
 >   // (wait r; 6)
 >   // stms:
 >   ssm_sensitize(r);
 >   actg->pc = N;
 >   return;
 > case N:
 >   ssm_desensitize(r);
 >   // exp: 6
 >
 >   // After the return, x is no longer initialized, so the following is
 >   // undefined behavior:
 >   x + 6

 To ensure this is cannot happen, we conservatively declare @x@ as a local
 variable in the activation record, so that its value is preserved between
 yields, even if this is not usually necessary. We leave it to later compiler
 passes to optimize this.
-}
genExpr :: I.Expr I.Type -> GenFn (C.Exp, [C.BlockItem])
genExpr :: Expr Type -> GenFn (Exp, [BlockItem])
genExpr (I.Var VarId
n Type
_) = do
  Maybe Exp
mv <- VarId -> Map VarId Exp -> Maybe Exp
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VarId
n (Map VarId Exp -> Maybe Exp)
-> GenFn (Map VarId Exp) -> GenFn (Maybe Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenFnState -> Map VarId Exp) -> GenFn (Map VarId Exp)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> Map VarId Exp
fnVars
  Exp
v <- GenFn Exp -> (Exp -> GenFn Exp) -> Maybe Exp -> GenFn Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe GenFn Exp
forall a. GenFn a
err Exp -> GenFn Exp
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Exp
mv
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
v, [])
 where
  err :: GenFn a
err = [Char] -> GenFn a
forall (m :: * -> *) a. MonadError Error m => [Char] -> m a
Compiler.unexpected ([Char] -> GenFn a) -> [Char] -> GenFn a
forall a b. (a -> b) -> a -> b
$ [Char]
"Codegen: Could not find I.Var named " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> VarId -> [Char]
forall a. Show a => a -> [Char]
show VarId
n
genExpr (I.Data DConId
dcon Type
_) = do
  Exp
e <- (DConInfo -> Exp) -> DConId -> GenFn Exp
forall a. (DConInfo -> a) -> DConId -> GenFn a
getsDCon DConInfo -> Exp
dconConstruct DConId
dcon
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
e, [])
genExpr (I.Lit Literal
l Type
ty) = do
  Exp
tmp <- Type -> GenFn Exp
genTmp Type
ty
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
tmp, [citems|$exp:tmp = $exp:(genLiteral l);|])
genExpr (I.Let [(I.BindVar VarId
n Type
_, Expr Type
d)] Expr Type
b Type
_) = do
  (Exp
defVal, [BlockItem]
defStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
d
  (VarId, Type)
-> GenFn (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall a. (VarId, Type) -> GenFn a -> GenFn a
withNewLocal (VarId
n, Expr Type -> Type
forall (c :: * -> *) a. Carrier c => c a -> a
I.extract Expr Type
d) (GenFn (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem]))
-> GenFn (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall a b. (a -> b) -> a -> b
$ do
    -- Look up n because withNewLocal may have mangled its name.
    Just Exp
n' <- VarId -> Map VarId Exp -> Maybe Exp
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup VarId
n (Map VarId Exp -> Maybe Exp)
-> GenFn (Map VarId Exp) -> GenFn (Maybe Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenFnState -> Map VarId Exp) -> GenFn (Map VarId Exp)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets GenFnState -> Map VarId Exp
fnVars
    let defInit :: [BlockItem]
defInit = [citems|$exp:n' = $exp:defVal;|]
    (Exp
bodyVal, [BlockItem]
bodyStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
b
    (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
bodyVal, [BlockItem]
defStms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
defInit [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
bodyStms)
genExpr (I.Let [(I.BindAnon Type
_, Expr Type
d)] Expr Type
b Type
_) = do
  (Exp
_, [BlockItem]
defStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
d -- Throw away value
  (Exp
bodyVal, [BlockItem]
bodyStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
b
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
bodyVal, [BlockItem]
defStms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
bodyStms)
genExpr I.Let{} = [Char] -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Cannot handle mutually recursive bindings"
genExpr e :: Expr Type
e@(I.App Expr Type
_ Expr Type
_ Type
ty) = do
  let (Expr Type
fn, [Expr Type]
args) = ([(Expr Type, Type)] -> [Expr Type])
-> (Expr Type, [(Expr Type, Type)]) -> (Expr Type, [Expr Type])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (((Expr Type, Type) -> Expr Type)
-> [(Expr Type, Type)] -> [Expr Type]
forall a b. (a -> b) -> [a] -> [b]
map (Expr Type, Type) -> Expr Type
forall a b. (a, b) -> a
fst) ((Expr Type, [(Expr Type, Type)]) -> (Expr Type, [Expr Type]))
-> (Expr Type, [(Expr Type, Type)]) -> (Expr Type, [Expr Type])
forall a b. (a -> b) -> a -> b
$ Expr Type -> (Expr Type, [(Expr Type, Type)])
forall t. Expr t -> (Expr t, [(Expr t, t)])
I.unfoldApp Expr Type
e
  -- args must be non-empty because a is an App
  case Expr Type
fn of
    -- I.Var _ _ -> do
    (I.Prim Primitive
I.Dup [I.Var VarId
_ Type
_] Type
_) -> do
      (Exp
fnExp, [BlockItem]
fnStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
fn
      ((Exp, [BlockItem]) -> Expr Type -> GenFn (Exp, [BlockItem]))
-> (Exp, [BlockItem]) -> [Expr Type] -> GenFn (Exp, [BlockItem])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Exp, [BlockItem]) -> Expr Type -> GenFn (Exp, [BlockItem])
apply (Exp
fnExp, [BlockItem]
fnStms) [Expr Type]
args
     where
      apply :: (Exp, [BlockItem]) -> Expr Type -> GenFn (Exp, [BlockItem])
apply (Exp
f, [BlockItem]
stms) Expr Type
a = do
        (Exp
aVal, [BlockItem]
aStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
a -- first evaluate argument
        Exp
ret <- Type -> GenFn Exp
genTmp Type
ty -- allocate return value address
        [BlockItem]
yield <- GenFn [BlockItem]
genYield -- application might necessitate yield
        let current :: Exp
current = [cexp|$id:actg|]
            prio :: Exp
prio = [cexp|$exp:current->$id:act_priority|]
            depth :: Exp
depth = [cexp|$exp:current->$id:act_depth|]
            retp :: Exp
retp = [cexp|&$exp:ret|]
            appStms :: [BlockItem]
appStms =
              [citems|
              $exp:(closure_apply f aVal current prio depth retp);
              if ($exp:(has_children current)) {
                $items:yield;
              }
              $exp:(drop f);
            |]
        (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
ret, [BlockItem]
stms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
aStms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
appStms)
    (I.Data DConId
dcon Type
dty) -> do
      ([Exp]
argVals, [[BlockItem]]
evalStms) <- [(Exp, [BlockItem])] -> ([Exp], [[BlockItem]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Exp, [BlockItem])] -> ([Exp], [[BlockItem]]))
-> GenFn [(Exp, [BlockItem])] -> GenFn ([Exp], [[BlockItem]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr Type -> GenFn (Exp, [BlockItem]))
-> [Expr Type] -> GenFn [(Exp, [BlockItem])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr Type -> GenFn (Exp, [BlockItem])
genExpr [Expr Type]
args
      Bool
onHeap <- (DConInfo -> Bool) -> DConId -> GenFn Bool
forall a. (DConInfo -> a) -> DConId -> GenFn a
getsDCon DConInfo -> Bool
dconOnHeap DConId
dcon
      Bool -> GenFn () -> GenFn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
onHeap (GenFn () -> GenFn ()) -> GenFn () -> GenFn ()
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> GenFn ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> GenFn ()) -> [Char] -> GenFn ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot handle packed fields yet, for: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ DConId -> [Char]
forall a. Show a => a -> [Char]
show DConId
dcon
      Exp
construct <- (DConInfo -> Exp) -> DConId -> GenFn Exp
forall a. (DConInfo -> a) -> DConId -> GenFn a
getsDCon DConInfo -> Exp
dconConstruct DConId
dcon
      Int -> Exp -> Exp
destruct <- (DConInfo -> Int -> Exp -> Exp)
-> DConId -> GenFn (Int -> Exp -> Exp)
forall a. (DConInfo -> a) -> DConId -> GenFn a
getsDCon DConInfo -> Int -> Exp -> Exp
dconDestruct DConId
dcon
      Exp
tmp <- Type -> GenFn Exp
genTmp Type
dty
      let alloc :: [BlockItem]
alloc = [[citem|$exp:tmp = $exp:construct;|]]
          initField :: a -> Int -> BlockItem
initField a
y Int
i = [citem|$exp:(destruct i tmp) = $exp:y;|]
          initFields :: [BlockItem]
initFields = (Exp -> Int -> BlockItem) -> [Exp] -> [Int] -> [BlockItem]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Exp -> Int -> BlockItem
forall a. ToExp a => a -> Int -> BlockItem
initField [Exp]
argVals [Int
0 ..]
      (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
tmp, [[BlockItem]] -> [BlockItem]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BlockItem]]
evalStms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
alloc [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
initFields)
    Expr Type
_ -> [Char] -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> GenFn (Exp, [BlockItem]))
-> [Char] -> GenFn (Exp, [BlockItem])
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot apply this expression: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Expr Type -> [Char]
forall a. Show a => a -> [Char]
show Expr Type
fn
genExpr (I.Match Expr Type
s [(Alt Type, Expr Type)]
as Type
t) = do
  -- To implement a match expression, we need to generate a C switch statement
  --
  -- which switches on the tag of the scrutinee @s@.
  -- However, since we're already using a switch statement for jumping to
  -- program counters, we cannot simply nest the switch statement, since we will
  -- risk the inner switch statement (for the match expression) shadowing the
  -- cases of the outer switch statement (for the program counters). In
  -- particular, we will be unable to yield inside of match expression arm with
  -- this naive compilation scheme.
  --
  -- So, in order to keep the C statements "flat", we use a basic block-style
  -- scheme, where the inner switch statement only jumps (using @goto@) to
  -- blocks corresponding to each arm of the match expression; this ensures that
  -- we never need to yield in the inner switch statement, thus side-stepping
  -- C's limitation. At the end of each block, we jump to a join statement that
  -- follows the blocks generated for each arm.
  (Exp
sExp, [BlockItem]
sStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
s
  Exp
scrut <- Type -> GenFn Exp
genTmp (Type -> GenFn Exp) -> Type -> GenFn Exp
forall a b. (a -> b) -> a -> b
$ Expr Type -> Type
forall (c :: * -> *) a. Carrier c => c a -> a
I.extract Expr Type
s
  Exp
val <- Type -> GenFn Exp
genTmp Type
t
  CIdent
joinLabel <- GenFn CIdent
freshLabel

  let assignScrut :: [BlockItem]
assignScrut = [citems|$exp:scrut = $exp:sExp;|]
      tag :: Exp
tag = Exp -> Exp
adt_tag Exp
scrut -- TODO: look this up using typeScrut
      switch :: [BlockItem] -> [BlockItem]
switch [BlockItem]
cases = [citems|switch ($exp:tag) { $items:cases }|]
      assignVal :: a -> [BlockItem]
assignVal a
e = [citems|$exp:val = $exp:e;|]
      joinStm :: [BlockItem]
joinStm = [citems|$id:joinLabel:;|]

      genArm :: (I.Alt I.Type, I.Expr I.Type) -> GenFn ([C.BlockItem], [C.BlockItem])
      genArm :: (Alt Type, Expr Type) -> GenFn ([BlockItem], [BlockItem])
genArm (Alt Type
alt, Expr Type
arm) = do
        CIdent
armLabel <- GenFn CIdent
freshLabel
        (BlockItem
altLabel, [BlockItem]
armBlk) <- CIdent
-> Alt Type -> GenFn [BlockItem] -> GenFn (BlockItem, [BlockItem])
withAltScope CIdent
armLabel Alt Type
alt (GenFn [BlockItem] -> GenFn (BlockItem, [BlockItem]))
-> GenFn [BlockItem] -> GenFn (BlockItem, [BlockItem])
forall a b. (a -> b) -> a -> b
$ do
          (Exp
armExp, [BlockItem]
armStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
arm
          [BlockItem] -> GenFn [BlockItem]
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem] -> GenFn [BlockItem])
-> [BlockItem] -> GenFn [BlockItem]
forall a b. (a -> b) -> a -> b
$ [BlockItem]
armStms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ Exp -> [BlockItem]
forall a. ToExp a => a -> [BlockItem]
assignVal Exp
armExp
        let armCase :: [BlockItem]
armCase = [citems|$item:altLabel goto $id:armLabel;|]
        ([BlockItem], [BlockItem]) -> GenFn ([BlockItem], [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockItem]
armCase, [BlockItem]
armBlk)
      mkBlk :: CIdent -> [C.BlockItem] -> [C.BlockItem]
      mkBlk :: CIdent -> [BlockItem] -> [BlockItem]
mkBlk CIdent
label [BlockItem]
blk =
        [citems|$id:label:;|] [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
blk [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [citems|goto $id:joinLabel;|]
      withAltScope
        :: CIdent
        -> I.Alt I.Type
        -> GenFn [C.BlockItem]
        -> GenFn (C.BlockItem, [C.BlockItem])
      withAltScope :: CIdent
-> Alt Type -> GenFn [BlockItem] -> GenFn (BlockItem, [BlockItem])
withAltScope CIdent
label a :: Alt Type
a@(I.AltData DConId
dcon [Alt Type]
_ Type
_) GenFn [BlockItem]
m = do
        Int -> Exp -> Exp
destruct <- (DConInfo -> Int -> Exp -> Exp)
-> DConId -> GenFn (Int -> Exp -> Exp)
forall a. (DConInfo -> a) -> DConId -> GenFn a
getsDCon DConInfo -> Int -> Exp -> Exp
dconDestruct DConId
dcon
        Exp
cas <- (DConInfo -> Exp) -> DConId -> GenFn Exp
forall a. (DConInfo -> a) -> DConId -> GenFn a
getsDCon DConInfo -> Exp
dconCase DConId
dcon
        -- NOTE: we assume here that this AltData is flat, i.e., the number of
        -- fields in the AltData is the same as what we expect for this data
        -- constructor (which we obtain from dconDestruct).
        let fieldBinds :: [(Binder Type, Exp)]
fieldBinds = Alt Type -> [Binder Type]
forall t. Alt t -> [Binder t]
I.altBinders Alt Type
a [Binder Type] -> [Exp] -> [(Binder Type, Exp)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` (Int -> Exp) -> [Int] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Exp -> Exp
`destruct` Exp
scrut) [Int
0 ..]
        [BlockItem]
blk <- [(Binder Type, Exp)] -> GenFn [BlockItem] -> GenFn [BlockItem]
forall a. [(Binder Type, Exp)] -> GenFn a -> GenFn a
withBindings [(Binder Type, Exp)]
fieldBinds GenFn [BlockItem]
m
        (BlockItem, [BlockItem]) -> GenFn (BlockItem, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return ([citem|case $exp:cas:;|], CIdent -> [BlockItem] -> [BlockItem]
mkBlk CIdent
label [BlockItem]
blk)
      withAltScope CIdent
label (I.AltLit Literal
l Type
_) GenFn [BlockItem]
m = do
        [BlockItem]
blk <- GenFn [BlockItem]
m
        (BlockItem, [BlockItem]) -> GenFn (BlockItem, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return ([citem|case $exp:(genLiteralRaw l):;|], CIdent -> [BlockItem] -> [BlockItem]
mkBlk CIdent
label [BlockItem]
blk)
      withAltScope CIdent
label (I.AltBinder Binder Type
b) GenFn [BlockItem]
m = do
        [BlockItem]
blk <- [(Binder Type, Exp)] -> GenFn [BlockItem] -> GenFn [BlockItem]
forall a. [(Binder Type, Exp)] -> GenFn a -> GenFn a
withBindings [(Binder Type
b, Exp
scrut)] GenFn [BlockItem]
m
        Binder Type -> Exp -> GenFn ()
addBinding Binder Type
b Exp
scrut
        (BlockItem, [BlockItem]) -> GenFn (BlockItem, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return ([citem|default:;|], CIdent -> [BlockItem] -> [BlockItem]
mkBlk CIdent
label [BlockItem]
blk)

  ([BlockItem]
cases, [BlockItem]
blks) <- ([[BlockItem]] -> [BlockItem])
-> ([[BlockItem]] -> [BlockItem])
-> ([[BlockItem]], [[BlockItem]])
-> ([BlockItem], [BlockItem])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [[BlockItem]] -> [BlockItem]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BlockItem]] -> [BlockItem]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([[BlockItem]], [[BlockItem]]) -> ([BlockItem], [BlockItem]))
-> ([([BlockItem], [BlockItem])] -> ([[BlockItem]], [[BlockItem]]))
-> [([BlockItem], [BlockItem])]
-> ([BlockItem], [BlockItem])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([BlockItem], [BlockItem])] -> ([[BlockItem]], [[BlockItem]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([BlockItem], [BlockItem])] -> ([BlockItem], [BlockItem]))
-> GenFn [([BlockItem], [BlockItem])]
-> GenFn ([BlockItem], [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Alt Type, Expr Type) -> GenFn ([BlockItem], [BlockItem]))
-> [(Alt Type, Expr Type)] -> GenFn [([BlockItem], [BlockItem])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Alt Type, Expr Type) -> GenFn ([BlockItem], [BlockItem])
genArm [(Alt Type, Expr Type)]
as
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
val, [BlockItem]
sStms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
assignScrut [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem] -> [BlockItem]
switch [BlockItem]
cases [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
blks [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
joinStm)
genExpr I.Lambda{} = [Char] -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Cannot handle lambdas"
genExpr (I.Prim Primitive
p [Expr Type]
es Type
t) = Primitive -> [Expr Type] -> Type -> GenFn (Exp, [BlockItem])
genPrim Primitive
p [Expr Type]
es Type
t
genExpr (I.Exception ExceptType
_ Type
t) = do
  Exp
tmp <- Type -> GenFn Exp
genTmp Type
t
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
tmp, [citems|$exp:(throw INTERNAL_ERROR);|]) -- unit instead of temp?


-- | Generate code for SSM primitive; see 'genExpr' for extended discussion.
genPrim
  :: I.Primitive -> [I.Expr I.Type] -> I.Type -> GenFn (C.Exp, [C.BlockItem])
genPrim :: Primitive -> [Expr Type] -> Type -> GenFn (Exp, [BlockItem])
genPrim Primitive
I.New [Expr Type
e] Type
refType = do
  (Exp
val, [BlockItem]
stms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
e
  Exp
tmp <- Type -> GenFn Exp
genTmp Type
refType
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
tmp, [BlockItem]
stms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [citems|$exp:tmp = $exp:(new_sv val); $exp:(drop val);|])
genPrim Primitive
I.Dup [Expr Type
e] Type
_ = do
  (Exp
val, [BlockItem]
stms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
e
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
val, [BlockItem]
stms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [citems|$exp:(dup val);|])
genPrim Primitive
I.Drop [Expr Type
e, Expr Type
r] Type
_ = do
  (Exp
val, [BlockItem]
stms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
e
  (Exp
ref, [BlockItem]
stms') <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
r -- NOTE: this should never really be side-effectful!
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
val, [BlockItem]
stms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
stms' [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [citems|$exp:(drop ref);|])
genPrim Primitive
I.Deref [Expr Type
a] Type
ty = do
  (Exp
val, [BlockItem]
stms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
a
  Exp
tmp <- Type -> GenFn Exp
genTmp Type
ty
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
tmp, [BlockItem]
stms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [citems|$exp:tmp = $exp:(deref val); $exp:(drop val);|])
genPrim Primitive
I.Assign [Expr Type
lhs, Expr Type
rhs] Type
_ = do
  (Exp
lhsVal, [BlockItem]
lhsStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
lhs
  (Exp
rhsVal, [BlockItem]
rhsStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
rhs
  let prio :: Exp
prio = [cexp|$id:actg->$id:act_priority|]
      assignBlock :: [BlockItem]
assignBlock =
        [citems|
          $items:lhsStms
          $items:rhsStms
          $exp:(assign lhsVal prio rhsVal);
          $exp:(drop rhsVal);
          $exp:(drop lhsVal);
        |]
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
unit, [BlockItem]
assignBlock)
genPrim Primitive
I.After [Expr Type
time, Expr Type
lhs, Expr Type
rhs] Type
_ = do
  (Exp
timeVal, [BlockItem]
timeStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
time
  (Exp
lhsVal, [BlockItem]
lhsStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
lhs
  (Exp
rhsVal, [BlockItem]
rhsStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
rhs
  let when :: Exp
when = [cexp|$exp:now() + $exp:(unmarshal timeVal)|]
      laterBlock :: [BlockItem]
laterBlock =
        [citems|
          $items:timeStms
          $items:lhsStms
          $items:rhsStms
          $exp:(later lhsVal when rhsVal);
          $exp:(drop timeVal);
          $exp:(drop rhsVal);
          $exp:(drop lhsVal);
        |]
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
unit, [BlockItem]
laterBlock)
genPrim Primitive
I.Par [Expr Type]
procs Type
_ = do
  let numChildren :: Int
numChildren = [Expr Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expr Type]
procs
      parArgs :: [(Exp, Exp)]
parArgs =
        Int -> (Exp, Exp) -> [(Exp, Exp)]
genParArgs
          Int
numChildren
          ([cexp|$id:actg->$id:act_priority|], [cexp|$id:actg->$id:act_depth|])

      checkNewDepth :: [BlockItem]
checkNewDepth =
        [citems|
          if ($id:actg->$id:act_depth < $exp:(depthSub numChildren))
            $exp:(throw EXHAUSTED_PRIORITY);
        |]

      -- FIXME: ideally, par expressions must all be parallel applications that
      -- don't yield/block. However, that relies on a liftPar pass that isn't
      -- implemented just yet.
      -- So, this is currently broken in that side effects inside the arguments
      -- of function calls will be evaluated sequentially, which is wrong.
      apply
        :: (I.Expr I.Type, (C.Exp, C.Exp))
        -> GenFn (C.Exp, [C.BlockItem], [C.BlockItem])
      apply :: (Expr Type, (Exp, Exp)) -> GenFn (Exp, [BlockItem], [BlockItem])
apply (I.App Expr Type
fn Expr Type
arg Type
ty, (Exp
prio, Exp
depth)) = do
        (Exp
fnExp, [BlockItem]
fnStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
fn
        (Exp
argExp, [BlockItem]
argStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
arg
        Exp
ret <- Type -> GenFn Exp
genTmp Type
ty
        let current :: Exp
current = [cexp|$id:actg|]
            retp :: Exp
retp = [cexp|&$exp:ret|]
            appStms :: [BlockItem]
appStms =
              [citems|
              $exp:(closure_apply fnExp argExp current prio depth retp);
              $exp:(drop fnExp);
            |]
        (Exp, [BlockItem], [BlockItem])
-> GenFn (Exp, [BlockItem], [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
ret, [BlockItem]
fnStms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
argStms, [BlockItem]
appStms)
      apply (Expr Type
e, (Exp, Exp)
_) = do
        [Char] -> GenFn (Exp, [BlockItem], [BlockItem])
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> GenFn (Exp, [BlockItem], [BlockItem]))
-> [Char] -> GenFn (Exp, [BlockItem], [BlockItem])
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot compile par with non-application expression: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Expr Type -> [Char]
forall a. Show a => a -> [Char]
show Expr Type
e

  ([Exp]
_rets, [[BlockItem]]
befores, [[BlockItem]]
activates) <- [(Exp, [BlockItem], [BlockItem])]
-> ([Exp], [[BlockItem]], [[BlockItem]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([(Exp, [BlockItem], [BlockItem])]
 -> ([Exp], [[BlockItem]], [[BlockItem]]))
-> GenFn [(Exp, [BlockItem], [BlockItem])]
-> GenFn ([Exp], [[BlockItem]], [[BlockItem]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Expr Type, (Exp, Exp)) -> GenFn (Exp, [BlockItem], [BlockItem]))
-> [(Expr Type, (Exp, Exp))]
-> GenFn [(Exp, [BlockItem], [BlockItem])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Expr Type, (Exp, Exp)) -> GenFn (Exp, [BlockItem], [BlockItem])
apply ([Expr Type] -> [(Exp, Exp)] -> [(Expr Type, (Exp, Exp))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Expr Type]
procs [(Exp, Exp)]
parArgs)
  [BlockItem]
yield <- GenFn [BlockItem]
genYield
  let parRetVal :: Exp
parRetVal = Exp
unit -- TODO: return tuple of values
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return
    (Exp
parRetVal, [BlockItem]
checkNewDepth [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [[BlockItem]] -> [BlockItem]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BlockItem]]
befores [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [[BlockItem]] -> [BlockItem]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BlockItem]]
activates [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
yield)
genPrim Primitive
I.Wait [Expr Type]
vars Type
_ = do
  ([Exp]
varVals, [[BlockItem]]
varStms) <- [(Exp, [BlockItem])] -> ([Exp], [[BlockItem]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Exp, [BlockItem])] -> ([Exp], [[BlockItem]]))
-> GenFn [(Exp, [BlockItem])] -> GenFn ([Exp], [[BlockItem]])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr Type -> GenFn (Exp, [BlockItem]))
-> [Expr Type] -> GenFn [(Exp, [BlockItem])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr Type -> GenFn (Exp, [BlockItem])
genExpr [Expr Type]
vars
  Int -> GenFn ()
maxWait (Int -> GenFn ()) -> Int -> GenFn ()
forall a b. (a -> b) -> a -> b
$ [Exp] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Exp]
varVals
  [BlockItem]
yield <- GenFn [BlockItem]
genYield
  let trigs :: [(Exp, Exp)]
trigs = [Exp] -> [Exp] -> [(Exp, Exp)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Exp]
varVals ([Exp] -> [(Exp, Exp)]) -> [Exp] -> [(Exp, Exp)]
forall a b. (a -> b) -> a -> b
$ (Int -> Exp) -> [Int] -> [Exp]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Exp
mkTrig [Int
1 :: Int ..]
      mkTrig :: Int -> Exp
mkTrig Int
i = [cexp|&$exp:(acts_ $ trig_ i)|]
      sens :: (Exp, Exp) -> BlockItem
sens (Exp
var, Exp
trig) = [citem|$exp:(sensitize var trig);|]
      desens :: (Exp, Exp) -> [BlockItem]
desens (Exp
var, Exp
trig) = [citems|$exp:(desensitize trig); $exp:(drop var);|]
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return
    (Exp
unit, [[BlockItem]] -> [BlockItem]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BlockItem]]
varStms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ ((Exp, Exp) -> BlockItem) -> [(Exp, Exp)] -> [BlockItem]
forall a b. (a -> b) -> [a] -> [b]
map (Exp, Exp) -> BlockItem
sens [(Exp, Exp)]
trigs [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
yield [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ ((Exp, Exp) -> [BlockItem]) -> [(Exp, Exp)] -> [BlockItem]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Exp, Exp) -> [BlockItem]
desens [(Exp, Exp)]
trigs)
genPrim Primitive
I.Loop [Expr Type
b] Type
_ = do
  (Exp
_, [BlockItem]
bodyStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
b
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
unit, [citems|for (;;) { $items:bodyStms }|])
genPrim Primitive
I.Break [] Type
_ = (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
undef, [citems|break;|])
genPrim Primitive
I.Now [] Type
t = do
  Exp
tmp <- Type -> GenFn Exp
genTmp Type
t
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
tmp, [citems|$exp:tmp = $exp:(new_time $ ccall now []);|])
genPrim Primitive
I.Last [Expr Type
r] Type
t = do
  (Exp
r', [BlockItem]
stms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
r
  Exp
tmp <- Type -> GenFn Exp
genTmp Type
t
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
tmp, [BlockItem]
stms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [citems|$exp:tmp = $exp:(new_time $ sv_last_updated r');|])
genPrim (I.CQuote [Char]
e) [] Type
_ = (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return ([cexp|$exp:(EscExp e)|], [])
genPrim (I.CCall CSym
s) [Expr Type]
es Type
_ = do
  ([Exp]
argExps, [BlockItem]
argStms) <- ([[BlockItem]] -> [BlockItem])
-> ([Exp], [[BlockItem]]) -> ([Exp], [BlockItem])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [[BlockItem]] -> [BlockItem]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([Exp], [[BlockItem]]) -> ([Exp], [BlockItem]))
-> ([(Exp, [BlockItem])] -> ([Exp], [[BlockItem]]))
-> [(Exp, [BlockItem])]
-> ([Exp], [BlockItem])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Exp, [BlockItem])] -> ([Exp], [[BlockItem]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Exp, [BlockItem])] -> ([Exp], [BlockItem]))
-> GenFn [(Exp, [BlockItem])] -> GenFn ([Exp], [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr Type -> GenFn (Exp, [BlockItem]))
-> [Expr Type] -> GenFn [(Exp, [BlockItem])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr Type -> GenFn (Exp, [BlockItem])
genExpr [Expr Type]
es
  -- TODO: obtain return value from call
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
unit, [BlockItem]
argStms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [citems|$id:s($args:argExps);|])
genPrim (I.FfiCall VarId
s) [Expr Type]
es Type
ty = do
  ([Exp]
argExps, [BlockItem]
argStms) <- ([[BlockItem]] -> [BlockItem])
-> ([Exp], [[BlockItem]]) -> ([Exp], [BlockItem])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [[BlockItem]] -> [BlockItem]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (([Exp], [[BlockItem]]) -> ([Exp], [BlockItem]))
-> ([(Exp, [BlockItem])] -> ([Exp], [[BlockItem]]))
-> [(Exp, [BlockItem])]
-> ([Exp], [BlockItem])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Exp, [BlockItem])] -> ([Exp], [[BlockItem]])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Exp, [BlockItem])] -> ([Exp], [BlockItem]))
-> GenFn [(Exp, [BlockItem])] -> GenFn ([Exp], [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Expr Type -> GenFn (Exp, [BlockItem]))
-> [Expr Type] -> GenFn [(Exp, [BlockItem])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Expr Type -> GenFn (Exp, [BlockItem])
genExpr [Expr Type]
es
  Exp
ret <- Type -> GenFn Exp
genTmp Type
ty
  let doDrop :: Exp -> BlockItem
doDrop Exp
arg = [citem|$exp:(drop arg);|]
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return
    ( Exp
ret
    , [BlockItem]
argStms
        [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [citems|$exp:ret = $id:s($args:argExps);|]
        [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ (Exp -> BlockItem) -> [Exp] -> [BlockItem]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> BlockItem
doDrop [Exp]
argExps
    )
genPrim (I.PrimOp PrimOp
op) [Expr Type]
es Type
t = do
  (Exp
opVal, [BlockItem]
opStms) <- PrimOp -> [Expr Type] -> Type -> GenFn (Exp, [BlockItem])
genPrimOp PrimOp
op [Expr Type]
es Type
t
  Exp
tmp <- Type -> GenFn Exp
genTmp Type
t
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp
tmp, [BlockItem]
opStms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [citems|$exp:tmp = $exp:opVal;|])
genPrim Primitive
_ [Expr Type]
_ Type
_ = [Char] -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Unsupported Primitive or wrong number of arguments"


-- | Generate C value for SSM literal, marshalled.
genLiteral :: I.Literal -> C.Exp
genLiteral :: Literal -> Exp
genLiteral = Exp -> Exp
marshal (Exp -> Exp) -> (Literal -> Exp) -> Literal -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Literal -> Exp
genLiteralRaw


-- | Generate C value for SSM literal, unmarshalled.
genLiteralRaw :: I.Literal -> C.Exp
genLiteralRaw :: Literal -> Exp
genLiteralRaw (I.LitIntegral Integer
i) = [cexp|$int:i|]
genLiteralRaw Literal
I.LitEvent = [cexp|1|]


-- | Generate C expression for SSM primitive operation.
genPrimOp
  :: I.PrimOp -> [I.Expr I.Type] -> I.Type -> GenFn (C.Exp, [C.BlockItem])
genPrimOp :: PrimOp -> [Expr Type] -> Type -> GenFn (Exp, [BlockItem])
genPrimOp PrimOp
I.PrimAdd [Expr Type
lhs, Expr Type
rhs] Type
_ = do
  ((Exp
lhsVal, Exp
rhsVal), [BlockItem]
stms) <-
    ((Exp, Exp) -> (Exp, Exp))
-> ((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Exp -> Exp) -> (Exp -> Exp) -> (Exp, Exp) -> (Exp, Exp)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Exp -> Exp
unmarshal Exp -> Exp
unmarshal) (((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem]))
-> GenFn ((Exp, Exp), [BlockItem])
-> GenFn ((Exp, Exp), [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> Expr Type -> GenFn ((Exp, Exp), [BlockItem])
genBinop Expr Type
lhs Expr Type
rhs
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
marshal [cexp|$exp:lhsVal + $exp:rhsVal|], [BlockItem]
stms)
-- TODO: optimization:
--  All integers are 31 bits + 1 tag bit, so zero tag bit on one argument,
-- add together, and the result will be sum with a tag bit of 1.
-- let val = word_to_val
--           [cexp|$exp:(val_to_word lhsVal) + ($exp:(val_to_word rhsVal) & ~1)|]
-- return (val, stms)
genPrimOp PrimOp
I.PrimSub [Expr Type
lhs, Expr Type
rhs] Type
_ = do
  ((Exp
lhsVal, Exp
rhsVal), [BlockItem]
stms) <-
    ((Exp, Exp) -> (Exp, Exp))
-> ((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Exp -> Exp) -> (Exp -> Exp) -> (Exp, Exp) -> (Exp, Exp)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Exp -> Exp
unmarshal Exp -> Exp
unmarshal) (((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem]))
-> GenFn ((Exp, Exp), [BlockItem])
-> GenFn ((Exp, Exp), [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> Expr Type -> GenFn ((Exp, Exp), [BlockItem])
genBinop Expr Type
lhs Expr Type
rhs
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
marshal [cexp|$exp:lhsVal - $exp:rhsVal|], [BlockItem]
stms)
genPrimOp PrimOp
I.PrimMul [Expr Type
lhs, Expr Type
rhs] Type
_ = do
  ((Exp
lhsVal, Exp
rhsVal), [BlockItem]
stms) <-
    ((Exp, Exp) -> (Exp, Exp))
-> ((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Exp -> Exp) -> (Exp -> Exp) -> (Exp, Exp) -> (Exp, Exp)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Exp -> Exp
unmarshal Exp -> Exp
unmarshal) (((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem]))
-> GenFn ((Exp, Exp), [BlockItem])
-> GenFn ((Exp, Exp), [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> Expr Type -> GenFn ((Exp, Exp), [BlockItem])
genBinop Expr Type
lhs Expr Type
rhs
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
marshal [cexp|$exp:lhsVal * $exp:rhsVal|], [BlockItem]
stms)
genPrimOp PrimOp
I.PrimDiv [Expr Type
lhs, Expr Type
rhs] Type
_ = do
  ((Exp
lhsVal, Exp
rhsVal), [BlockItem]
stms) <-
    ((Exp, Exp) -> (Exp, Exp))
-> ((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Exp -> Exp) -> (Exp -> Exp) -> (Exp, Exp) -> (Exp, Exp)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Exp -> Exp
unmarshal Exp -> Exp
unmarshal) (((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem]))
-> GenFn ((Exp, Exp), [BlockItem])
-> GenFn ((Exp, Exp), [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> Expr Type -> GenFn ((Exp, Exp), [BlockItem])
genBinop Expr Type
lhs Expr Type
rhs
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
marshal [cexp|$exp:lhsVal / $exp:rhsVal|], [BlockItem]
stms)
genPrimOp PrimOp
I.PrimMod [Expr Type
lhs, Expr Type
rhs] Type
_ = do
  ((Exp
lhsVal, Exp
rhsVal), [BlockItem]
stms) <-
    ((Exp, Exp) -> (Exp, Exp))
-> ((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Exp -> Exp) -> (Exp -> Exp) -> (Exp, Exp) -> (Exp, Exp)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Exp -> Exp
unmarshal Exp -> Exp
unmarshal) (((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem]))
-> GenFn ((Exp, Exp), [BlockItem])
-> GenFn ((Exp, Exp), [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> Expr Type -> GenFn ((Exp, Exp), [BlockItem])
genBinop Expr Type
lhs Expr Type
rhs
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
marshal [cexp|$exp:lhsVal % $exp:rhsVal|], [BlockItem]
stms)
genPrimOp PrimOp
I.PrimNeg [Expr Type
opr] Type
_ = do
  (Exp
val, [BlockItem]
stms) <- (Exp -> Exp) -> (Exp, [BlockItem]) -> (Exp, [BlockItem])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Exp -> Exp
unmarshal ((Exp, [BlockItem]) -> (Exp, [BlockItem]))
-> GenFn (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
opr
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
marshal [cexp|- $exp:val|], [BlockItem]
stms)
genPrimOp PrimOp
I.PrimBitAnd [Expr Type
lhs, Expr Type
rhs] Type
_ = do
  ((Exp
lhsVal, Exp
rhsVal), [BlockItem]
stms) <-
    ((Exp, Exp) -> (Exp, Exp))
-> ((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Exp -> Exp) -> (Exp -> Exp) -> (Exp, Exp) -> (Exp, Exp)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Exp -> Exp
unmarshal Exp -> Exp
unmarshal) (((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem]))
-> GenFn ((Exp, Exp), [BlockItem])
-> GenFn ((Exp, Exp), [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> Expr Type -> GenFn ((Exp, Exp), [BlockItem])
genBinop Expr Type
lhs Expr Type
rhs
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
marshal [cexp|$exp:lhsVal & $exp:rhsVal|], [BlockItem]
stms)
genPrimOp PrimOp
I.PrimBitOr [Expr Type
lhs, Expr Type
rhs] Type
_ = do
  ((Exp
lhsVal, Exp
rhsVal), [BlockItem]
stms) <-
    ((Exp, Exp) -> (Exp, Exp))
-> ((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Exp -> Exp) -> (Exp -> Exp) -> (Exp, Exp) -> (Exp, Exp)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Exp -> Exp
unmarshal Exp -> Exp
unmarshal) (((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem]))
-> GenFn ((Exp, Exp), [BlockItem])
-> GenFn ((Exp, Exp), [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> Expr Type -> GenFn ((Exp, Exp), [BlockItem])
genBinop Expr Type
lhs Expr Type
rhs
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
marshal [cexp|$exp:lhsVal | $exp:rhsVal|], [BlockItem]
stms)
genPrimOp PrimOp
I.PrimBitNot [Expr Type
opr] Type
_ = do
  (Exp
val, [BlockItem]
stms) <- (Exp -> Exp) -> (Exp, [BlockItem]) -> (Exp, [BlockItem])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Exp -> Exp
unmarshal ((Exp, [BlockItem]) -> (Exp, [BlockItem]))
-> GenFn (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
opr
  -- TODO: optimization:
  -- all integers are 31 bits + 1 tag bit, so val XOR (~1) flips the 31 bits and
  -- keeps the tag bit 1.
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
marshal [cexp|($exp:val ^ (~1))|], [BlockItem]
stms)
genPrimOp PrimOp
I.PrimEq [Expr Type
lhs, Expr Type
rhs] Type
_ = do
  ((Exp
lhsVal, Exp
rhsVal), [BlockItem]
stms) <-
    ((Exp, Exp) -> (Exp, Exp))
-> ((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Exp -> Exp) -> (Exp -> Exp) -> (Exp, Exp) -> (Exp, Exp)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Exp -> Exp
unmarshal Exp -> Exp
unmarshal) (((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem]))
-> GenFn ((Exp, Exp), [BlockItem])
-> GenFn ((Exp, Exp), [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> Expr Type -> GenFn ((Exp, Exp), [BlockItem])
genBinop Expr Type
lhs Expr Type
rhs
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
marshal [cexp|$exp:lhsVal == $exp:rhsVal|], [BlockItem]
stms)
genPrimOp PrimOp
I.PrimNeq [Expr Type
lhs, Expr Type
rhs] Type
_ = do
  ((Exp
lhsVal, Exp
rhsVal), [BlockItem]
stms) <-
    ((Exp, Exp) -> (Exp, Exp))
-> ((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Exp -> Exp) -> (Exp -> Exp) -> (Exp, Exp) -> (Exp, Exp)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Exp -> Exp
unmarshal Exp -> Exp
unmarshal) (((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem]))
-> GenFn ((Exp, Exp), [BlockItem])
-> GenFn ((Exp, Exp), [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> Expr Type -> GenFn ((Exp, Exp), [BlockItem])
genBinop Expr Type
lhs Expr Type
rhs
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
marshal [cexp|$exp:lhsVal != $exp:rhsVal|], [BlockItem]
stms)
genPrimOp PrimOp
I.PrimNot [Expr Type
opr] Type
_ = do
  (Exp
val, [BlockItem]
stms) <- (Exp -> Exp) -> (Exp, [BlockItem]) -> (Exp, [BlockItem])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Exp -> Exp
unmarshal ((Exp, [BlockItem]) -> (Exp, [BlockItem]))
-> GenFn (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
opr
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
marshal [cexp|! $exp:val|], [BlockItem]
stms)
genPrimOp PrimOp
I.PrimGt [Expr Type
lhs, Expr Type
rhs] Type
_ = do
  let unmarshal' :: Exp -> Exp
unmarshal' = CSize -> Exp -> Exp
cast_to_signed CSize
Size32 (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Exp -> Exp
`shl` Int -> Exp
cint Int
1) (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp
unmarshal
  ((Exp
lhsVal, Exp
rhsVal), [BlockItem]
stms) <-
    ((Exp, Exp) -> (Exp, Exp))
-> ((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Exp -> Exp) -> (Exp -> Exp) -> (Exp, Exp) -> (Exp, Exp)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Exp -> Exp
unmarshal' Exp -> Exp
unmarshal') (((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem]))
-> GenFn ((Exp, Exp), [BlockItem])
-> GenFn ((Exp, Exp), [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> Expr Type -> GenFn ((Exp, Exp), [BlockItem])
genBinop Expr Type
lhs Expr Type
rhs
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
marshal [cexp|$exp:lhsVal > $exp:rhsVal|], [BlockItem]
stms)
genPrimOp PrimOp
I.PrimGe [Expr Type
lhs, Expr Type
rhs] Type
_ = do
  let unmarshal' :: Exp -> Exp
unmarshal' = CSize -> Exp -> Exp
cast_to_signed CSize
Size32 (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Exp -> Exp
`shl` Int -> Exp
cint Int
1) (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp
unmarshal
  ((Exp
lhsVal, Exp
rhsVal), [BlockItem]
stms) <-
    ((Exp, Exp) -> (Exp, Exp))
-> ((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Exp -> Exp) -> (Exp -> Exp) -> (Exp, Exp) -> (Exp, Exp)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Exp -> Exp
unmarshal' Exp -> Exp
unmarshal') (((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem]))
-> GenFn ((Exp, Exp), [BlockItem])
-> GenFn ((Exp, Exp), [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> Expr Type -> GenFn ((Exp, Exp), [BlockItem])
genBinop Expr Type
lhs Expr Type
rhs
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
marshal [cexp|$exp:lhsVal >= $exp:rhsVal|], [BlockItem]
stms)
genPrimOp PrimOp
I.PrimLt [Expr Type
lhs, Expr Type
rhs] Type
_ = do
  let unmarshal' :: Exp -> Exp
unmarshal' = CSize -> Exp -> Exp
cast_to_signed CSize
Size32 (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Exp -> Exp
`shl` Int -> Exp
cint Int
1) (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp
unmarshal
  ((Exp
lhsVal, Exp
rhsVal), [BlockItem]
stms) <-
    ((Exp, Exp) -> (Exp, Exp))
-> ((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Exp -> Exp) -> (Exp -> Exp) -> (Exp, Exp) -> (Exp, Exp)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Exp -> Exp
unmarshal' Exp -> Exp
unmarshal') (((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem]))
-> GenFn ((Exp, Exp), [BlockItem])
-> GenFn ((Exp, Exp), [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> Expr Type -> GenFn ((Exp, Exp), [BlockItem])
genBinop Expr Type
lhs Expr Type
rhs
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
marshal [cexp|$exp:lhsVal < $exp:rhsVal|], [BlockItem]
stms)
genPrimOp PrimOp
I.PrimLe [Expr Type
lhs, Expr Type
rhs] Type
_ = do
  let unmarshal' :: Exp -> Exp
unmarshal' = CSize -> Exp -> Exp
cast_to_signed CSize
Size32 (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Exp -> Exp -> Exp
`shl` Int -> Exp
cint Int
1) (Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Exp -> Exp
unmarshal
  ((Exp
lhsVal, Exp
rhsVal), [BlockItem]
stms) <-
    ((Exp, Exp) -> (Exp, Exp))
-> ((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem])
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Exp -> Exp) -> (Exp -> Exp) -> (Exp, Exp) -> (Exp, Exp)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Exp -> Exp
unmarshal' Exp -> Exp
unmarshal') (((Exp, Exp), [BlockItem]) -> ((Exp, Exp), [BlockItem]))
-> GenFn ((Exp, Exp), [BlockItem])
-> GenFn ((Exp, Exp), [BlockItem])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Expr Type -> Expr Type -> GenFn ((Exp, Exp), [BlockItem])
genBinop Expr Type
lhs Expr Type
rhs
  (Exp, [BlockItem]) -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Exp
marshal [cexp|$exp:lhsVal <= $exp:rhsVal|], [BlockItem]
stms)
genPrimOp PrimOp
_ [Expr Type]
_ Type
_ = [Char] -> GenFn (Exp, [BlockItem])
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Unsupported PrimOp or wrong number of arguments"


-- | Helper for sequencing across binary operations.
genBinop
  :: I.Expr I.Type -> I.Expr I.Type -> GenFn ((C.Exp, C.Exp), [C.BlockItem])
genBinop :: Expr Type -> Expr Type -> GenFn ((Exp, Exp), [BlockItem])
genBinop Expr Type
lhs Expr Type
rhs = do
  (Exp
lhsVal, [BlockItem]
lhsStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
lhs
  (Exp
rhsVal, [BlockItem]
rhsStms) <- Expr Type -> GenFn (Exp, [BlockItem])
genExpr Expr Type
rhs
  ((Exp, Exp), [BlockItem]) -> GenFn ((Exp, Exp), [BlockItem])
forall (m :: * -> *) a. Monad m => a -> m a
return ((Exp
lhsVal, Exp
rhsVal), [BlockItem]
lhsStms [BlockItem] -> [BlockItem] -> [BlockItem]
forall a. [a] -> [a] -> [a]
++ [BlockItem]
rhsStms)


-- | Compute priority and depth arguments for a par fork of given width.
genParArgs :: Int -> (C.Exp, C.Exp) -> [(C.Exp, C.Exp)]
genParArgs :: Int -> (Exp, Exp) -> [(Exp, Exp)]
genParArgs Int
width (Exp
currentPrio, Exp
currentDepth) =
  [ let p :: Exp
p = [cexp|$exp:currentPrio + ($int:(i-1) * (1 << $exp:d))|]
        d :: Exp
d = [cexp|$exp:currentDepth - $exp:(depthSub width)|]
     in (Exp
p, Exp
d)
  | Int
i <- [Int
1 .. Int
width]
  ]


-- | How much the depth should be decreased when par forking given width.
depthSub :: Int -> C.Exp
depthSub :: Int -> Exp
depthSub Int
width = [cexp|$int:ds|]
 where
  ds :: Int
ds = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase (Double
2 :: Double) (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width :: Int