-- | Generate definitions that allow importing C implementations of
-- floating-point operations into Bluespec.
module Copilot.Compile.Bluespec.FloatingPoint
  ( copilotBluespecFloatingPointBSV
  , copilotBluespecFloatingPointC
  ) where

-- | The contents of the generated @BluespecFP.bsv@ file, which contains the
-- @import \"BDPI\"@ declarations needed to use imported C functions in
-- Bluespec.
copilotBluespecFloatingPointBSV :: String
copilotBluespecFloatingPointBSV :: String
copilotBluespecFloatingPointBSV =
  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    [ String
"import FloatingPoint::*;"
    , String
""
    ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
      (\String
funName -> [FloatType -> String -> String
importOp1 FloatType
Float String
funName, FloatType -> String -> String
importOp1 FloatType
Double String
funName])
      [String]
unaryFloatOpNames [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
      (\String
funName -> [FloatType -> String -> String
importOp2 FloatType
Float String
funName, FloatType -> String -> String
importOp2 FloatType
Double String
funName])
      [ String
"pow"
      , String
"atan2"
      , String
"logb"
      ]
  where
    importOp1 :: FloatType -> String -> String
    importOp1 :: FloatType -> String -> String
importOp1 FloatType
ft String
funName =
      String
"import \"BDPI\" function " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
floatTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
funNamePrefix
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
funName String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
floatTypeSuffix FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
floatTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" x);"

    importOp2 :: FloatType -> String -> String
    importOp2 :: FloatType -> String -> String
importOp2 FloatType
ft String
funName =
      String
"import \"BDPI\" function " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
floatTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
funNamePrefix
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
funName String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
floatTypeSuffix FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
floatTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" x, "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
floatTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" y);"

    floatTypeName :: FloatType -> String
    floatTypeName :: FloatType -> String
floatTypeName FloatType
Float  = String
"Float"
    floatTypeName FloatType
Double = String
"Double"

-- | The contents of the generated @bs_fp.c@ file, which contains the C wrapper
-- functions that Bluespec imports.
copilotBluespecFloatingPointC :: String
copilotBluespecFloatingPointC :: String
copilotBluespecFloatingPointC =
  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    [ String
"#include <math.h>"
    , String
""
    , FloatType -> String
defineUnionType FloatType
Float
    , FloatType -> String
defineUnionType FloatType
Double
    ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
      (\String
funName -> [FloatType -> String -> String
defineOp1 FloatType
Float String
funName, FloatType -> String -> String
defineOp1 FloatType
Double String
funName])
      [String]
unaryFloatOpNames [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
      (\String
funName -> [FloatType -> String -> String
defineOp2 FloatType
Float String
funName, FloatType -> String -> String
defineOp2 FloatType
Double String
funName])
      [ String
"pow"
      , String
"atan2"
      ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    -- There is no direct C counterpart to the `logb` function, so we implement
    -- it in terms of `log`.
    (FloatType -> String) -> [FloatType] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
      (\FloatType
ft ->
        FloatType
-> String -> (String -> String -> String -> String) -> String
defineOp2Skeleton FloatType
ft String
"logb" ((String -> String -> String -> String) -> String)
-> (String -> String -> String -> String) -> String
forall a b. (a -> b) -> a -> b
$
        \String
_cFunName String
x String
y -> String
"log" String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
floatTypeSuffix FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") / log"
                            String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
floatTypeSuffix FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"( " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
      [FloatType
Float, FloatType
Double]
  where
    defineUnionType :: FloatType -> String
    defineUnionType :: FloatType -> String
defineUnionType FloatType
ft =
      [String] -> String
unlines
        [ String
"union " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
unionTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" {"
        , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
integerTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" i;"
        , String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
floatTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" f;"
        , String
"};"
        ]

    defineOp1Skeleton ::
      FloatType -> String -> (String -> String -> String) -> String
    defineOp1Skeleton :: FloatType -> String -> (String -> String -> String) -> String
defineOp1Skeleton FloatType
ft String
funName String -> String -> String
mkFloatOp =
      let cFunName :: String
cFunName = String
funName String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
floatTypeSuffix FloatType
ft in
      [String] -> String
unlines
        [ FloatType -> String
integerTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
funNamePrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cFunName
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
integerTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" x) {"
        , String
"  union " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
unionTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" x_u;"
        , String
"  union " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
unionTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" r_u;"
        , String
"  x_u.i = x;"
        , String
"  r_u.f = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String
mkFloatOp String
cFunName String
"x_u.f" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
        , String
"  return r_u.i;"
        , String
"}"
        ]

    defineOp1 :: FloatType -> String -> String
    defineOp1 :: FloatType -> String -> String
defineOp1 FloatType
ft String
funName =
      FloatType -> String -> (String -> String -> String) -> String
defineOp1Skeleton FloatType
ft String
funName ((String -> String -> String) -> String)
-> (String -> String -> String) -> String
forall a b. (a -> b) -> a -> b
$
      \String
cFunName String
x -> String
cFunName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

    defineOp2Skeleton ::
      FloatType -> String -> (String -> String -> String -> String) -> String
    defineOp2Skeleton :: FloatType
-> String -> (String -> String -> String -> String) -> String
defineOp2Skeleton FloatType
ft String
funName String -> String -> String -> String
mkFloatOp =
      let cFunName :: String
cFunName = String
funName String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
floatTypeSuffix FloatType
ft in
      [String] -> String
unlines
        [ FloatType -> String
integerTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
funNamePrefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cFunName
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
integerTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" x, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
integerTypeName FloatType
ft
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" y) {"
        , String
"  union " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
unionTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" x_u;"
        , String
"  union " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
unionTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" y_u;"
        , String
"  union " String -> String -> String
forall a. [a] -> [a] -> [a]
++ FloatType -> String
unionTypeName FloatType
ft String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" r_u;"
        , String
"  x_u.i = x;"
        , String
"  y_u.i = y;"
        , String
"  r_u.f = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String -> String -> String
mkFloatOp String
cFunName String
"x_u.f" String
"y_u.f" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
        , String
"  return r_u.i;"
        , String
"}"
        ]

    defineOp2 :: FloatType -> String -> String
    defineOp2 :: FloatType -> String -> String
defineOp2 FloatType
ft String
funName =
      FloatType
-> String -> (String -> String -> String -> String) -> String
defineOp2Skeleton FloatType
ft String
funName ((String -> String -> String -> String) -> String)
-> (String -> String -> String -> String) -> String
forall a b. (a -> b) -> a -> b
$
      \String
cFunName String
x String
y -> String
cFunName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

    integerTypeName :: FloatType -> String
    integerTypeName :: FloatType -> String
integerTypeName FloatType
Float  = String
"unsigned int"
    integerTypeName FloatType
Double = String
"unsigned long long"

    floatTypeName :: FloatType -> String
    floatTypeName :: FloatType -> String
floatTypeName FloatType
Float  = String
"float"
    floatTypeName FloatType
Double = String
"double"

    unionTypeName :: FloatType -> String
    unionTypeName :: FloatType -> String
unionTypeName FloatType
Float  = String
"ui_float"
    unionTypeName FloatType
Double = String
"ull_double"

-- * Internals

-- | Are we generating a function for a @float@ or @double@ operation?
data FloatType
  = Float
  | Double

-- | The suffix to use in the generated function.
floatTypeSuffix :: FloatType -> String
floatTypeSuffix :: FloatType -> String
floatTypeSuffix FloatType
Float  = String
"f"
floatTypeSuffix FloatType
Double = String
""

-- | The prefix to use in the generated function.
funNamePrefix :: String
funNamePrefix :: String
funNamePrefix = String
"bs_fp_"

-- | The names of unary floating-point operations.
unaryFloatOpNames :: [String]
unaryFloatOpNames :: [String]
unaryFloatOpNames =
  [ String
"exp"
  , String
"log"
  , String
"acos"
  , String
"asin"
  , String
"atan"
  , String
"cos"
  , String
"sin"
  , String
"tan"
  , String
"acosh"
  , String
"asinh"
  , String
"atanh"
  , String
"cosh"
  , String
"sinh"
  , String
"tanh"
  , String
"ceil"
  , String
"floor"
  , String
"sqrt"
  ]