{-# LANGUAGE QuasiQuotes #-}

{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

-- | C code generation of primitive Feldspar expressions

module Feldspar.Primitive.Backend.C where



import Data.Complex

import Data.Constraint (Dict (..))
import Data.Proxy

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

import Language.C.Monad
import Language.Embedded.Backend.C

import Language.Syntactic

import Feldspar.Primitive.Representation



-- Note: This module assumes a 32-bit target. For example the C function `abs`
-- is used up to 32-bits, and `labs` is used above that.

viewLitPrim :: ASTF (Primitive :&: PrimTypeRep) a -> Maybe a
viewLitPrim :: ASTF (Primitive :&: PrimTypeRep) a -> Maybe a
viewLitPrim (Sym (Lit a
a :&: PrimTypeRep (DenResult (Full a))
_)) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
viewLitPrim (Sym (Primitive (Full a)
Pi :&: PrimTypeRep (DenResult (Full a))
_))    = a -> Maybe a
forall a. a -> Maybe a
Just a
forall a. Floating a => a
pi
viewLitPrim ASTF (Primitive :&: PrimTypeRep) a
_ = Maybe a
forall a. Maybe a
Nothing

instance CompTypeClass PrimType'
  where
    compType :: proxy1 PrimType' -> proxy2 a -> m Type
compType proxy1 PrimType'
_ (proxy2 a
_ :: proxy a) = case PrimTypeRep a
forall a. PrimType' a => PrimTypeRep a
primTypeRep :: PrimTypeRep a of
      PrimTypeRep a
BoolT   -> String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<stdbool.h>" m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename bool     |]
      PrimTypeRep a
Int8T   -> String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<stdint.h>"  m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename int8_t   |]
      PrimTypeRep a
Int16T  -> String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<stdint.h>"  m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename int16_t  |]
      PrimTypeRep a
Int32T  -> String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<stdint.h>"  m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename int32_t  |]
      PrimTypeRep a
Int64T  -> String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<stdint.h>"  m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename int64_t  |]
      PrimTypeRep a
Word8T  -> String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<stdint.h>"  m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename uint8_t  |]
      PrimTypeRep a
Word16T -> String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<stdint.h>"  m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename uint16_t |]
      PrimTypeRep a
Word32T -> String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<stdint.h>"  m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename uint32_t |]
      PrimTypeRep a
Word64T -> String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<stdint.h>"  m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| typename uint64_t |]
      PrimTypeRep a
FloatT  -> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| float |]
      PrimTypeRep a
DoubleT -> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| double |]
      PrimTypeRep a
ComplexFloatT  -> String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| float  _Complex |]
      PrimTypeRep a
ComplexDoubleT -> String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Type -> m Type
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Type -> m Type
forall (m :: * -> *) a. Monad m => a -> m a
return [cty| double _Complex |]

    compLit :: proxy PrimType' -> a -> m Exp
compLit proxy PrimType'
_ a
a = case a -> PrimTypeRep a
forall a. PrimType' a => a -> PrimTypeRep a
primTypeOf a
a of
      PrimTypeRep a
BoolT   -> do String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<stdbool.h>"
                    Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ if a
Bool
a then [cexp| true |] else [cexp| false |]
      PrimTypeRep a
Int8T   -> Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $a |]
      PrimTypeRep a
Int16T  -> Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $a |]
      PrimTypeRep a
Int32T  -> Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $a |]
      PrimTypeRep a
Int64T  -> Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $a |]
      PrimTypeRep a
Word8T  -> Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $a |]
      PrimTypeRep a
Word16T -> Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $a |]
      PrimTypeRep a
Word32T -> Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $a |]
      PrimTypeRep a
Word64T -> Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $a |]
      PrimTypeRep a
FloatT  -> Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $a |]
      PrimTypeRep a
DoubleT -> Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $a |]
      PrimTypeRep a
ComplexFloatT  -> Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Complex Float -> Exp
forall a. (Eq a, Num a, ToExp a) => Complex a -> Exp
compComplexLit a
Complex Float
a
      PrimTypeRep a
ComplexDoubleT -> Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Complex Double -> Exp
forall a. (Eq a, Num a, ToExp a) => Complex a -> Exp
compComplexLit a
Complex Double
a

-- | Compile a complex literal
compComplexLit :: (Eq a, Num a, ToExp a) => Complex a -> C.Exp
compComplexLit :: Complex a -> Exp
compComplexLit (a
r :+ a
0) = [cexp| $r |]
compComplexLit (a
0 :+ a
i) = [cexp| $i * I |]
compComplexLit (a
r :+ a
i) = [cexp| $r + $i * I |]

addTagMacro :: MonadC m => m ()
addTagMacro :: m ()
addTagMacro = Definition -> m ()
forall (m :: * -> *). MonadC m => Definition -> m ()
addGlobal [cedecl|$esc:("#define TAG(tag,exp) (exp)")|]

-- | Compile a unary operator
compUnOp :: MonadC m => C.UnOp -> ASTF PrimDomain a -> m C.Exp
compUnOp :: UnOp -> ASTF (Primitive :&: PrimTypeRep) a -> m Exp
compUnOp UnOp
op ASTF (Primitive :&: PrimTypeRep) a
a = do
    Exp
a' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ ASTF (Primitive :&: PrimTypeRep) a -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim ASTF (Primitive :&: PrimTypeRep) a
a
    Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ UnOp -> Exp -> SrcLoc -> Exp
C.UnOp UnOp
op Exp
a' SrcLoc
forall a. Monoid a => a
mempty

-- | Compile a binary operator
compBinOp :: MonadC m =>
    C.BinOp -> ASTF PrimDomain a -> ASTF PrimDomain b -> m C.Exp
compBinOp :: BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
op ASTF (Primitive :&: PrimTypeRep) a
a ASTF (Primitive :&: PrimTypeRep) b
b = do
    Exp
a' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ ASTF (Primitive :&: PrimTypeRep) a -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim ASTF (Primitive :&: PrimTypeRep) a
a
    Exp
b' <- Prim b -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim b -> m Exp) -> Prim b -> m Exp
forall a b. (a -> b) -> a -> b
$ ASTF (Primitive :&: PrimTypeRep) b -> Prim b
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim ASTF (Primitive :&: PrimTypeRep) b
b
    Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ BinOp -> Exp -> Exp -> SrcLoc -> Exp
C.BinOp BinOp
op Exp
a' Exp
b' SrcLoc
forall a. Monoid a => a
mempty

-- | Compile a function call
compFun :: MonadC m => String -> Args (AST PrimDomain) sig -> m C.Exp
compFun :: String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
fun Args (AST (Primitive :&: PrimTypeRep)) sig
args = do
    [Exp]
as <- [m Exp] -> m [Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([m Exp] -> m [Exp]) -> [m Exp] -> m [Exp]
forall a b. (a -> b) -> a -> b
$ (forall a. AST (Primitive :&: PrimTypeRep) (Full a) -> m Exp)
-> Args (AST (Primitive :&: PrimTypeRep)) sig -> [m Exp]
forall (c :: * -> *) b sig.
(forall a. c (Full a) -> b) -> Args c sig -> [b]
listArgs (Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp)
-> (ASTF (Primitive :&: PrimTypeRep) a -> Prim a)
-> ASTF (Primitive :&: PrimTypeRep) a
-> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim) Args (AST (Primitive :&: PrimTypeRep)) sig
args
    Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $id:fun($args:as) |]

-- | Compile a call to 'abs'
compAbs :: MonadC m => PrimTypeRep a -> ASTF PrimDomain a -> m C.Exp
compAbs :: PrimTypeRep a -> ASTF (Primitive :&: PrimTypeRep) a -> m Exp
compAbs PrimTypeRep a
t ASTF (Primitive :&: PrimTypeRep) a
a = case PrimTypeRep a -> PrimTypeView a
forall a. PrimTypeRep a -> PrimTypeView a
viewPrimTypeRep PrimTypeRep a
t of
    PrimTypeView a
PrimTypeBool     -> String -> m Exp
forall a. HasCallStack => String -> a
error String
"compAbs: type BoolT not supported"
    PrimTypeIntWord (IntType IntTypeRep a
_)  -> String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<stdlib.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String
-> Args (AST (Primitive :&: PrimTypeRep)) (a :-> Full Any) -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"abs" (ASTF (Primitive :&: PrimTypeRep) a
a ASTF (Primitive :&: PrimTypeRep) a
-> Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
-> Args (AST (Primitive :&: PrimTypeRep)) (a :-> Full Any)
forall (c :: * -> *) a sig1.
c (Full a) -> Args c sig1 -> Args c (a :-> sig1)
:* Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
forall (c :: * -> *) a. Args c (Full a)
Nil)
    PrimTypeIntWord (WordType WordTypeRep a
_) -> Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ ASTF (Primitive :&: PrimTypeRep) a -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim ASTF (Primitive :&: PrimTypeRep) a
a
    PrimTypeView a
_ -> String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String
-> Args (AST (Primitive :&: PrimTypeRep)) (a :-> Full Any) -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"fabs" (ASTF (Primitive :&: PrimTypeRep) a
a ASTF (Primitive :&: PrimTypeRep) a
-> Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
-> Args (AST (Primitive :&: PrimTypeRep)) (a :-> Full Any)
forall (c :: * -> *) a sig1.
c (Full a) -> Args c sig1 -> Args c (a :-> sig1)
:* Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
forall (c :: * -> *) a. Args c (Full a)
Nil)
      -- Floating and complex types

complexSign_def :: Definition
complexSign_def = [cedecl|
double _Complex feld_complexSign(double _Complex c) {
    double z = cabs(c);
    if (z == 0) {
        return 0;
    } else {
        return (creal(c)/z + I*(cimag(c)/z));
    }
}
|]

complexSignf_def :: Definition
complexSignf_def = [cedecl|
float _Complex feld_complexSignf(float _Complex c) {
    float z = cabsf(c);
    if (z == 0) {
        return 0;
    } else {
        return (crealf(c)/z + I*(cimagf(c)/z));
    }
}
|]

-- | Compile a call to 'signum'
compSign :: MonadC m => PrimTypeRep a -> ASTF PrimDomain a -> m C.Exp
compSign :: PrimTypeRep a -> ASTF (Primitive :&: PrimTypeRep) a -> m Exp
compSign PrimTypeRep a
t ASTF (Primitive :&: PrimTypeRep) a
a = case PrimTypeRep a -> PrimTypeView a
forall a. PrimTypeRep a -> PrimTypeView a
viewPrimTypeRep PrimTypeRep a
t of
    PrimTypeView a
PrimTypeBool -> String -> m Exp
forall a. HasCallStack => String -> a
error String
"compSign: type BoolT not supported"
    PrimTypeIntWord (WordType WordTypeRep a
_) -> do
        m ()
forall (m :: * -> *). MonadC m => m ()
addTagMacro
        Exp
a' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ ASTF (Primitive :&: PrimTypeRep) a -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim ASTF (Primitive :&: PrimTypeRep) a
a
        Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| TAG("signum", $a' > 0) |]
    PrimTypeIntWord (IntType IntTypeRep a
_) -> do
        m ()
forall (m :: * -> *). MonadC m => m ()
addTagMacro
        Exp
a' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ ASTF (Primitive :&: PrimTypeRep) a -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim ASTF (Primitive :&: PrimTypeRep) a
a
        Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| TAG("signum", ($a' > 0) - ($a' < 0)) |]
    PrimTypeFloating FloatingTypeRep a
FloatType -> do
        m ()
forall (m :: * -> *). MonadC m => m ()
addTagMacro
        Exp
a' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ ASTF (Primitive :&: PrimTypeRep) a -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim ASTF (Primitive :&: PrimTypeRep) a
a
        Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| TAG("signum", (float) (($a' > 0) - ($a' < 0))) |]
    PrimTypeFloating FloatingTypeRep a
DoubleType -> do
        m ()
forall (m :: * -> *). MonadC m => m ()
addTagMacro
        Exp
a' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ ASTF (Primitive :&: PrimTypeRep) a -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim ASTF (Primitive :&: PrimTypeRep) a
a
        Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| TAG("signum", (double) (($a' > 0) - ($a' < 0))) |]
    PrimTypeComplex ComplexTypeRep a
ComplexDoubleType -> do
        String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>"
        Definition -> m ()
forall (m :: * -> *). MonadC m => Definition -> m ()
addGlobal Definition
complexSign_def
        Exp
a' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ ASTF (Primitive :&: PrimTypeRep) a -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim ASTF (Primitive :&: PrimTypeRep) a
a
        Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| feld_complexSign($a') |]
    PrimTypeComplex ComplexTypeRep a
ComplexFloatType -> do
        String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<complex.h>"
        Definition -> m ()
forall (m :: * -> *). MonadC m => Definition -> m ()
addGlobal Definition
complexSignf_def
        Exp
a' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ ASTF (Primitive :&: PrimTypeRep) a -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim ASTF (Primitive :&: PrimTypeRep) a
a
        Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| feld_complexSignf($a') |]
  -- TODO The floating point cases give `sign (-0.0) = 0.0`, which is (slightly)
  -- wrong. They should return -0.0. I don't know whether it's correct for other
  -- strange values.

-- | Compile a type casted primitive expression
compCast :: MonadC m => PrimTypeRep a -> ASTF PrimDomain b -> m C.Exp
compCast :: PrimTypeRep a -> ASTF (Primitive :&: PrimTypeRep) b -> m Exp
compCast PrimTypeRep a
t ASTF (Primitive :&: PrimTypeRep) b
a = Prim b -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (ASTF (Primitive :&: PrimTypeRep) b -> Prim b
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim ASTF (Primitive :&: PrimTypeRep) b
a) m Exp -> (Exp -> m Exp) -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PrimTypeRep a -> Exp -> m Exp
forall (m :: * -> *) a. MonadC m => PrimTypeRep a -> Exp -> m Exp
compCastExp PrimTypeRep a
t

-- | Applies type cast on a compiled expression
compCastExp :: MonadC m => PrimTypeRep a -> C.Exp -> m C.Exp
compCastExp :: PrimTypeRep a -> Exp -> m Exp
compCastExp PrimTypeRep a
t Exp
a
    | Dict (PrimType' a)
Dict <- PrimTypeRep a -> Dict (PrimType' a)
forall a. PrimTypeRep a -> Dict (PrimType' a)
witPrimType PrimTypeRep a
t = do
        Type
t' <- Proxy PrimType' -> PrimTypeRep a -> m Type
forall (ct :: * -> Constraint) a (m :: * -> *)
       (proxy1 :: (* -> Constraint) -> *) (proxy2 :: * -> *).
(CompTypeClass ct, ct a, MonadC m) =>
proxy1 ct -> proxy2 a -> m Type
compType (Proxy PrimType'
forall k (t :: k). Proxy t
Proxy :: Proxy PrimType') PrimTypeRep a
t
        Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp|($ty:t') $a|]

-- | Compile a call to 'round'
--   A cast is added to the resulting expression to allow compatibility
--   between different integral and floating return types.
compRound :: (PrimType' a, Num a, RealFrac b, MonadC m) =>
    PrimTypeRep a -> ASTF PrimDomain b -> m C.Exp
compRound :: PrimTypeRep a -> ASTF (Primitive :&: PrimTypeRep) b -> m Exp
compRound PrimTypeRep a
t ASTF (Primitive :&: PrimTypeRep) b
a = do
    String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>"
    Exp
rounded <- case PrimTypeRep a -> PrimTypeView a
forall a. PrimTypeRep a -> PrimTypeView a
viewPrimTypeRep PrimTypeRep a
t of
        PrimTypeIntWord IntWordTypeRep a
_  -> String
-> Args (AST (Primitive :&: PrimTypeRep)) (b :-> Full Any) -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"lround" (ASTF (Primitive :&: PrimTypeRep) b
a ASTF (Primitive :&: PrimTypeRep) b
-> Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
-> Args (AST (Primitive :&: PrimTypeRep)) (b :-> Full Any)
forall (c :: * -> *) a sig1.
c (Full a) -> Args c sig1 -> Args c (a :-> sig1)
:* Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
forall (c :: * -> *) a. Args c (Full a)
Nil)
        PrimTypeFloating FloatingTypeRep a
_ -> String
-> Args (AST (Primitive :&: PrimTypeRep)) (b :-> Full Any) -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"round"  (ASTF (Primitive :&: PrimTypeRep) b
a ASTF (Primitive :&: PrimTypeRep) b
-> Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
-> Args (AST (Primitive :&: PrimTypeRep)) (b :-> Full Any)
forall (c :: * -> *) a sig1.
c (Full a) -> Args c sig1 -> Args c (a :-> sig1)
:* Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
forall (c :: * -> *) a. Args c (Full a)
Nil)
        PrimTypeComplex ComplexTypeRep a
_  -> String
-> Args (AST (Primitive :&: PrimTypeRep)) (b :-> Full Any) -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"round"  (ASTF (Primitive :&: PrimTypeRep) b
a ASTF (Primitive :&: PrimTypeRep) b
-> Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
-> Args (AST (Primitive :&: PrimTypeRep)) (b :-> Full Any)
forall (c :: * -> *) a sig1.
c (Full a) -> Args c sig1 -> Args c (a :-> sig1)
:* Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
forall (c :: * -> *) a. Args c (Full a)
Nil)
        PrimTypeView a
_ -> String -> m Exp
forall a. HasCallStack => String -> a
error (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ String
"compRound: type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PrimTypeRep a -> String
forall a. Show a => a -> String
show PrimTypeRep a
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not supported"
    PrimTypeRep a -> Exp -> m Exp
forall (m :: * -> *) a. MonadC m => PrimTypeRep a -> Exp -> m Exp
compCastExp PrimTypeRep a
t Exp
rounded

-- Note: There's no problem with including both `tgmath.h` and `math.h`. As long
-- as the former is included, including the latter (before or after) doesn't
-- make a difference.
--
-- See: <https://gist.github.com/emilaxelsson/51310b3353f96914cd9bdb18b10b3103>

div_def :: Definition
div_def = [cedecl|
int feld_div(int x, int y) {
    int q = x/y;
    int r = x%y;
    if ((r!=0) && ((r<0) != (y<0))) --q;
    return q;
}
|]

ldiv_def :: Definition
ldiv_def = [cedecl|
long int feld_ldiv(long int x, long int y) {
    int q = x/y;
    int r = x%y;
    if ((r!=0) && ((r<0) != (y<0))) --q;
    return q;
}
|]

mod_def :: Definition
mod_def = [cedecl|
int feld_mod(int x, int y) {
    int r = x%y;
    if ((r!=0) && ((r<0) != (y<0))) { r += y; }
    return r;
}
|]

lmod_def :: Definition
lmod_def = [cedecl|
long int feld_lmod(long int x, long int y) {
    int r = x%y;
    if ((r!=0) && ((r<0) != (y<0))) { r += y; }
    return r;
}
|]

-- The above C implementations are taken from
-- <http://www.microhowto.info/howto/round_towards_minus_infinity_when_dividing_integers_in_c_or_c++.html>

compDiv :: MonadC m =>
    PrimTypeRep a -> ASTF PrimDomain a -> ASTF PrimDomain b -> m C.Exp
compDiv :: PrimTypeRep a
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compDiv PrimTypeRep a
t ASTF (Primitive :&: PrimTypeRep) a
a ASTF (Primitive :&: PrimTypeRep) b
b = case PrimTypeRep a -> PrimTypeView a
forall a. PrimTypeRep a -> PrimTypeView a
viewPrimTypeRep PrimTypeRep a
t of
    PrimTypeIntWord (WordType WordTypeRep a
_) -> BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Div ASTF (Primitive :&: PrimTypeRep) a
a ASTF (Primitive :&: PrimTypeRep) b
b
    PrimTypeIntWord (IntType IntTypeRep a
Int64Type) -> do
        Definition -> m ()
forall (m :: * -> *). MonadC m => Definition -> m ()
addGlobal Definition
ldiv_def
        String
-> Args (AST (Primitive :&: PrimTypeRep)) (a :-> (b :-> Full Any))
-> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"feld_ldiv" (ASTF (Primitive :&: PrimTypeRep) a
a ASTF (Primitive :&: PrimTypeRep) a
-> Args (AST (Primitive :&: PrimTypeRep)) (b :-> Full Any)
-> Args (AST (Primitive :&: PrimTypeRep)) (a :-> (b :-> Full Any))
forall (c :: * -> *) a sig1.
c (Full a) -> Args c sig1 -> Args c (a :-> sig1)
:* ASTF (Primitive :&: PrimTypeRep) b
b ASTF (Primitive :&: PrimTypeRep) b
-> Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
-> Args (AST (Primitive :&: PrimTypeRep)) (b :-> Full Any)
forall (c :: * -> *) a sig1.
c (Full a) -> Args c sig1 -> Args c (a :-> sig1)
:* Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
forall (c :: * -> *) a. Args c (Full a)
Nil)
    PrimTypeIntWord IntWordTypeRep a
_ -> do
        Definition -> m ()
forall (m :: * -> *). MonadC m => Definition -> m ()
addGlobal Definition
div_def
        String
-> Args (AST (Primitive :&: PrimTypeRep)) (a :-> (b :-> Full Any))
-> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"feld_div" (ASTF (Primitive :&: PrimTypeRep) a
a ASTF (Primitive :&: PrimTypeRep) a
-> Args (AST (Primitive :&: PrimTypeRep)) (b :-> Full Any)
-> Args (AST (Primitive :&: PrimTypeRep)) (a :-> (b :-> Full Any))
forall (c :: * -> *) a sig1.
c (Full a) -> Args c sig1 -> Args c (a :-> sig1)
:* ASTF (Primitive :&: PrimTypeRep) b
b ASTF (Primitive :&: PrimTypeRep) b
-> Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
-> Args (AST (Primitive :&: PrimTypeRep)) (b :-> Full Any)
forall (c :: * -> *) a sig1.
c (Full a) -> Args c sig1 -> Args c (a :-> sig1)
:* Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
forall (c :: * -> *) a. Args c (Full a)
Nil)
    PrimTypeView a
_ -> String -> m Exp
forall a. HasCallStack => String -> a
error (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ String
"compDiv: type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PrimTypeRep a -> String
forall a. Show a => a -> String
show PrimTypeRep a
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not supported"

compMod :: MonadC m =>
    PrimTypeRep a -> ASTF PrimDomain a -> ASTF PrimDomain b -> m C.Exp
compMod :: PrimTypeRep a
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compMod PrimTypeRep a
t ASTF (Primitive :&: PrimTypeRep) a
a ASTF (Primitive :&: PrimTypeRep) b
b = case PrimTypeRep a -> PrimTypeView a
forall a. PrimTypeRep a -> PrimTypeView a
viewPrimTypeRep PrimTypeRep a
t of
    PrimTypeIntWord (WordType WordTypeRep a
_) -> BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Mod ASTF (Primitive :&: PrimTypeRep) a
a ASTF (Primitive :&: PrimTypeRep) b
b
    PrimTypeIntWord (IntType IntTypeRep a
Int64Type) -> do
        Definition -> m ()
forall (m :: * -> *). MonadC m => Definition -> m ()
addGlobal Definition
lmod_def
        String
-> Args (AST (Primitive :&: PrimTypeRep)) (a :-> (b :-> Full Any))
-> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"feld_lmod" (ASTF (Primitive :&: PrimTypeRep) a
a ASTF (Primitive :&: PrimTypeRep) a
-> Args (AST (Primitive :&: PrimTypeRep)) (b :-> Full Any)
-> Args (AST (Primitive :&: PrimTypeRep)) (a :-> (b :-> Full Any))
forall (c :: * -> *) a sig1.
c (Full a) -> Args c sig1 -> Args c (a :-> sig1)
:* ASTF (Primitive :&: PrimTypeRep) b
b ASTF (Primitive :&: PrimTypeRep) b
-> Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
-> Args (AST (Primitive :&: PrimTypeRep)) (b :-> Full Any)
forall (c :: * -> *) a sig1.
c (Full a) -> Args c sig1 -> Args c (a :-> sig1)
:* Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
forall (c :: * -> *) a. Args c (Full a)
Nil)
    PrimTypeIntWord IntWordTypeRep a
_ -> do
        Definition -> m ()
forall (m :: * -> *). MonadC m => Definition -> m ()
addGlobal Definition
mod_def
        String
-> Args (AST (Primitive :&: PrimTypeRep)) (a :-> (b :-> Full Any))
-> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"feld_mod" (ASTF (Primitive :&: PrimTypeRep) a
a ASTF (Primitive :&: PrimTypeRep) a
-> Args (AST (Primitive :&: PrimTypeRep)) (b :-> Full Any)
-> Args (AST (Primitive :&: PrimTypeRep)) (a :-> (b :-> Full Any))
forall (c :: * -> *) a sig1.
c (Full a) -> Args c sig1 -> Args c (a :-> sig1)
:* ASTF (Primitive :&: PrimTypeRep) b
b ASTF (Primitive :&: PrimTypeRep) b
-> Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
-> Args (AST (Primitive :&: PrimTypeRep)) (b :-> Full Any)
forall (c :: * -> *) a sig1.
c (Full a) -> Args c sig1 -> Args c (a :-> sig1)
:* Args (AST (Primitive :&: PrimTypeRep)) (Full Any)
forall (c :: * -> *) a. Args c (Full a)
Nil)
    PrimTypeView a
_ -> String -> m Exp
forall a. HasCallStack => String -> a
error (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ String
"compMod: type " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PrimTypeRep a -> String
forall a. Show a => a -> String
show PrimTypeRep a
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not supported"

-- | Compile an expression
compPrim :: MonadC m => Prim a -> m C.Exp
compPrim :: Prim a -> m Exp
compPrim = (forall sig.
 (a ~ DenResult sig) =>
 PrimDomain sig
 -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp)
-> ASTF (Primitive :&: PrimTypeRep) a -> m Exp
forall (sym :: * -> *) a b.
(forall sig.
 (a ~ DenResult sig) =>
 sym sig -> Args (AST sym) sig -> b)
-> ASTF sym a -> b
simpleMatch (\(s :&: t) -> PrimTypeRep (DenResult sig)
-> Primitive sig
-> Args (AST (Primitive :&: PrimTypeRep)) sig
-> m Exp
forall (m :: * -> *) sig.
MonadC m =>
PrimTypeRep (DenResult sig)
-> Primitive sig
-> Args (AST (Primitive :&: PrimTypeRep)) sig
-> m Exp
go PrimTypeRep (DenResult sig)
t Primitive sig
s) (ASTF (Primitive :&: PrimTypeRep) a -> m Exp)
-> (Prim a -> ASTF (Primitive :&: PrimTypeRep) a)
-> Prim a
-> m Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prim a -> ASTF (Primitive :&: PrimTypeRep) a
forall a. Prim a -> ASTF (Primitive :&: PrimTypeRep) a
unPrim
  where
    go :: forall m sig . MonadC m
        => PrimTypeRep (DenResult sig)
        -> Primitive sig
        -> Args (AST PrimDomain) sig
        -> m C.Exp
    go :: PrimTypeRep (DenResult sig)
-> Primitive sig
-> Args (AST (Primitive :&: PrimTypeRep)) sig
-> m Exp
go PrimTypeRep (DenResult sig)
_ (FreeVar String
v) Args (AST (Primitive :&: PrimTypeRep)) sig
Nil = String -> m ()
forall (m :: * -> *) v. (MonadC m, ToIdent v) => v -> m ()
touchVar String
v m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $id:v |]
    go PrimTypeRep (DenResult sig)
t (Lit a
a) Args (AST (Primitive :&: PrimTypeRep)) sig
Nil
        | Dict (PrimType' a)
Dict <- PrimTypeRep a -> Dict (PrimType' a)
forall a. PrimTypeRep a -> Dict (PrimType' a)
witPrimType PrimTypeRep a
PrimTypeRep (DenResult sig)
t
        = Proxy PrimType' -> a -> m Exp
forall (ct :: * -> Constraint) a (m :: * -> *)
       (proxy :: (* -> Constraint) -> *).
(CompTypeClass ct, ct a, MonadC m) =>
proxy ct -> a -> m Exp
compLit (Proxy PrimType'
forall k (t :: k). Proxy t
Proxy :: Proxy PrimType') a
a
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Add  (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Add AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Sub  (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Sub AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Mul  (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Mul AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Neg  (AST (Primitive :&: PrimTypeRep) (Full a)
a :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil)      = UnOp -> AST (Primitive :&: PrimTypeRep) (Full a) -> m Exp
forall (m :: * -> *) a.
MonadC m =>
UnOp -> ASTF (Primitive :&: PrimTypeRep) a -> m Exp
compUnOp UnOp
C.Negate AST (Primitive :&: PrimTypeRep) (Full a)
a
    go PrimTypeRep (DenResult sig)
t Primitive sig
Abs  (AST (Primitive :&: PrimTypeRep) (Full a)
a :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil)      = PrimTypeRep a -> AST (Primitive :&: PrimTypeRep) (Full a) -> m Exp
forall (m :: * -> *) a.
MonadC m =>
PrimTypeRep a -> ASTF (Primitive :&: PrimTypeRep) a -> m Exp
compAbs PrimTypeRep a
PrimTypeRep (DenResult sig)
t AST (Primitive :&: PrimTypeRep) (Full a)
a
    go PrimTypeRep (DenResult sig)
t Primitive sig
Sign (AST (Primitive :&: PrimTypeRep) (Full a)
a :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil)      = PrimTypeRep a -> AST (Primitive :&: PrimTypeRep) (Full a) -> m Exp
forall (m :: * -> *) a.
MonadC m =>
PrimTypeRep a -> ASTF (Primitive :&: PrimTypeRep) a -> m Exp
compSign PrimTypeRep a
PrimTypeRep (DenResult sig)
t AST (Primitive :&: PrimTypeRep) (Full a)
a

    go PrimTypeRep (DenResult sig)
_ Primitive sig
Quot (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Div AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Rem  (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Mod AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
t Primitive sig
Div  (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = PrimTypeRep a
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
PrimTypeRep a
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compDiv PrimTypeRep a
PrimTypeRep (DenResult sig)
t AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
t Primitive sig
Mod  (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = PrimTypeRep a
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
PrimTypeRep a
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compMod PrimTypeRep a
PrimTypeRep (DenResult sig)
t AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
_ Primitive sig
FDiv (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Div AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b

    go PrimTypeRep (DenResult sig)
_ Primitive sig
Pi Args (AST (Primitive :&: PrimTypeRep)) sig
Nil = Definition -> m ()
forall (m :: * -> *). MonadC m => Definition -> m ()
addGlobal Definition
pi_def m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| FELD_PI |]
      where pi_def :: Definition
pi_def = [cedecl|$esc:("#define FELD_PI 3.141592653589793")|]
              -- This is the value of `pi :: Double`.
              -- Apparently there is no standard C99 definition of pi.
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Exp   Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"exp" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Log   Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"log" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Sqrt  Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"sqrt" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Pow   Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"pow" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Sin   Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"sin" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Cos   Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"cos" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Tan   Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"tan" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Asin  Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"asin" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Acos  Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"acos" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Atan  Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"atan" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Sinh  Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"sinh" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Cosh  Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"cosh" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Tanh  Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"tanh" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Asinh Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"asinh" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Acosh Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"acosh" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Atanh Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"atanh" Args (AST (Primitive :&: PrimTypeRep)) sig
args

    go PrimTypeRep (DenResult sig)
_ Primitive sig
Complex (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = do
        String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>"
        Exp
a' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ AST (Primitive :&: PrimTypeRep) (Full a) -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim AST (Primitive :&: PrimTypeRep) (Full a)
a
        Exp
b' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ AST (Primitive :&: PrimTypeRep) (Full a) -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim AST (Primitive :&: PrimTypeRep) (Full a)
b
        Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ case (AST (Primitive :&: PrimTypeRep) (Full a) -> Maybe a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Maybe a
viewLitPrim AST (Primitive :&: PrimTypeRep) (Full a)
a, AST (Primitive :&: PrimTypeRep) (Full a) -> Maybe a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Maybe a
viewLitPrim AST (Primitive :&: PrimTypeRep) (Full a)
b) of
            (Just a
0, Maybe a
_) -> [cexp| I*$b'       |]
            (Maybe a
_, Just a
0) -> [cexp| $a'         |]
            (Maybe a, Maybe a)
_           -> [cexp| $a' + I*$b' |]
      -- We assume that constant folding has been performed, so that not both
      -- `a` and `b` are constants
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Polar (AST (Primitive :&: PrimTypeRep) (Full a)
m :* AST (Primitive :&: PrimTypeRep) (Full a)
p :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil)
        | Just a
0 <- AST (Primitive :&: PrimTypeRep) (Full a) -> Maybe a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Maybe a
viewLitPrim AST (Primitive :&: PrimTypeRep) (Full a)
m = Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| 0 |]
        | Just a
0 <- AST (Primitive :&: PrimTypeRep) (Full a) -> Maybe a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Maybe a
viewLitPrim AST (Primitive :&: PrimTypeRep) (Full a)
p = do
            Exp
m' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ AST (Primitive :&: PrimTypeRep) (Full a) -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim AST (Primitive :&: PrimTypeRep) (Full a)
m
            Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $m' |]
        | Just a
1 <- AST (Primitive :&: PrimTypeRep) (Full a) -> Maybe a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Maybe a
viewLitPrim AST (Primitive :&: PrimTypeRep) (Full a)
m = do
            Exp
p' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ AST (Primitive :&: PrimTypeRep) (Full a) -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim AST (Primitive :&: PrimTypeRep) (Full a)
p
            Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| exp(I*$p') |]
        | Bool
otherwise = do
            Exp
m' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ AST (Primitive :&: PrimTypeRep) (Full a) -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim AST (Primitive :&: PrimTypeRep) (Full a)
m
            Exp
p' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ AST (Primitive :&: PrimTypeRep) (Full a) -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim AST (Primitive :&: PrimTypeRep) (Full a)
p
            Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $m' * exp(I*$p') |]
      -- We assume that constant folding has been performed, so that not both
      -- `m` and `p` are constants
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Real      Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"creal" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Imag      Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"cimag" Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Magnitude Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"cabs"  Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Phase     Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"carg"  Args (AST (Primitive :&: PrimTypeRep)) sig
args
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Conjugate Args (AST (Primitive :&: PrimTypeRep)) sig
args = String -> m ()
forall (m :: * -> *). MonadC m => String -> m ()
addInclude String
"<tgmath.h>" m () -> m Exp -> m Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
forall (m :: * -> *) sig.
MonadC m =>
String -> Args (AST (Primitive :&: PrimTypeRep)) sig -> m Exp
compFun String
"conj"  Args (AST (Primitive :&: PrimTypeRep)) sig
args

    go PrimTypeRep (DenResult sig)
t Primitive sig
I2N   (AST (Primitive :&: PrimTypeRep) (Full a)
a :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = PrimTypeRep b -> AST (Primitive :&: PrimTypeRep) (Full a) -> m Exp
forall (m :: * -> *) a b.
MonadC m =>
PrimTypeRep a -> ASTF (Primitive :&: PrimTypeRep) b -> m Exp
compCast PrimTypeRep b
PrimTypeRep (DenResult sig)
t AST (Primitive :&: PrimTypeRep) (Full a)
a
    go PrimTypeRep (DenResult sig)
t Primitive sig
I2B   (AST (Primitive :&: PrimTypeRep) (Full a)
a :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = PrimTypeRep Bool
-> AST (Primitive :&: PrimTypeRep) (Full a) -> m Exp
forall (m :: * -> *) a b.
MonadC m =>
PrimTypeRep a -> ASTF (Primitive :&: PrimTypeRep) b -> m Exp
compCast PrimTypeRep Bool
PrimTypeRep (DenResult sig)
t AST (Primitive :&: PrimTypeRep) (Full a)
a
    go PrimTypeRep (DenResult sig)
t Primitive sig
B2I   (AST (Primitive :&: PrimTypeRep) (Full a)
a :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = PrimTypeRep a -> AST (Primitive :&: PrimTypeRep) (Full a) -> m Exp
forall (m :: * -> *) a b.
MonadC m =>
PrimTypeRep a -> ASTF (Primitive :&: PrimTypeRep) b -> m Exp
compCast PrimTypeRep a
PrimTypeRep (DenResult sig)
t AST (Primitive :&: PrimTypeRep) (Full a)
a
    go PrimTypeRep (DenResult sig)
t Primitive sig
Round (AST (Primitive :&: PrimTypeRep) (Full a)
a :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = PrimTypeRep b -> AST (Primitive :&: PrimTypeRep) (Full a) -> m Exp
forall a b (m :: * -> *).
(PrimType' a, Num a, RealFrac b, MonadC m) =>
PrimTypeRep a -> ASTF (Primitive :&: PrimTypeRep) b -> m Exp
compRound PrimTypeRep b
PrimTypeRep (DenResult sig)
t AST (Primitive :&: PrimTypeRep) (Full a)
a

    go PrimTypeRep (DenResult sig)
_ Primitive sig
Not  (AST (Primitive :&: PrimTypeRep) (Full a)
a :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil)      = UnOp -> AST (Primitive :&: PrimTypeRep) (Full a) -> m Exp
forall (m :: * -> *) a.
MonadC m =>
UnOp -> ASTF (Primitive :&: PrimTypeRep) a -> m Exp
compUnOp UnOp
C.Lnot AST (Primitive :&: PrimTypeRep) (Full a)
a
    go PrimTypeRep (DenResult sig)
_ Primitive sig
And  (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Land AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Or   (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Lor AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Eq   (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Eq AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
_ Primitive sig
NEq  (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Ne AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Lt   (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Lt AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Gt   (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Gt AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Le   (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Le AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
_ Primitive sig
Ge   (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Ge AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b

    go PrimTypeRep (DenResult sig)
_ Primitive sig
BitAnd   (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.And AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
_ Primitive sig
BitOr    (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Or AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
_ Primitive sig
BitXor   (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Xor AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
_ Primitive sig
BitCompl (AST (Primitive :&: PrimTypeRep) (Full a)
a :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil)      = UnOp -> AST (Primitive :&: PrimTypeRep) (Full a) -> m Exp
forall (m :: * -> *) a.
MonadC m =>
UnOp -> ASTF (Primitive :&: PrimTypeRep) a -> m Exp
compUnOp UnOp
C.Not AST (Primitive :&: PrimTypeRep) (Full a)
a
    go PrimTypeRep (DenResult sig)
_ Primitive sig
ShiftL   (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Lsh AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b
    go PrimTypeRep (DenResult sig)
_ Primitive sig
ShiftR   (AST (Primitive :&: PrimTypeRep) (Full a)
a :* AST (Primitive :&: PrimTypeRep) (Full a)
b :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = BinOp
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> AST (Primitive :&: PrimTypeRep) (Full a)
-> m Exp
forall (m :: * -> *) a b.
MonadC m =>
BinOp
-> ASTF (Primitive :&: PrimTypeRep) a
-> ASTF (Primitive :&: PrimTypeRep) b
-> m Exp
compBinOp BinOp
C.Rsh AST (Primitive :&: PrimTypeRep) (Full a)
a AST (Primitive :&: PrimTypeRep) (Full a)
b

    go PrimTypeRep (DenResult sig)
_ (ArrIx IArr Index a
arr) (AST (Primitive :&: PrimTypeRep) (Full a)
i :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = do
        Exp
i' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ AST (Primitive :&: PrimTypeRep) (Full a) -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim AST (Primitive :&: PrimTypeRep) (Full a)
i
        IArr Index a -> m ()
forall (m :: * -> *) v. (MonadC m, ToIdent v) => v -> m ()
touchVar IArr Index a
arr
        Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return [cexp| $id:arr[$i'] |]

    go PrimTypeRep (DenResult sig)
_ Primitive sig
Cond (AST (Primitive :&: PrimTypeRep) (Full a)
c :* AST (Primitive :&: PrimTypeRep) (Full a)
t :* AST (Primitive :&: PrimTypeRep) (Full a)
f :* Args (AST (Primitive :&: PrimTypeRep)) sig1
Nil) = do
        Exp
c' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ AST (Primitive :&: PrimTypeRep) (Full a) -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim AST (Primitive :&: PrimTypeRep) (Full a)
c
        Exp
t' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ AST (Primitive :&: PrimTypeRep) (Full a) -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim AST (Primitive :&: PrimTypeRep) (Full a)
t
        Exp
f' <- Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim (Prim a -> m Exp) -> Prim a -> m Exp
forall a b. (a -> b) -> a -> b
$ AST (Primitive :&: PrimTypeRep) (Full a) -> Prim a
forall a. ASTF (Primitive :&: PrimTypeRep) a -> Prim a
Prim AST (Primitive :&: PrimTypeRep) (Full a)
f
        Exp -> m Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> m Exp) -> Exp -> m Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp -> SrcLoc -> Exp
C.Cond Exp
c' Exp
t' Exp
f' SrcLoc
forall a. Monoid a => a
mempty

instance CompExp Prim where compExp :: Prim a -> m Exp
compExp = Prim a -> m Exp
forall (m :: * -> *) a. MonadC m => Prim a -> m Exp
compPrim