----------------------------------------------------------------
--                                                    2016.12.20
-- |
-- Module      :  Language.Hakaru.CodeGen.Libraries
-- Copyright   :  Copyright (c) 2016 the Hakaru team
-- License     :  BSD3
-- Maintainer  :  zsulliva@indiana.edu
-- Stability   :  experimental
-- Portability :  GHC-only
--
-- Bindings to common C libraries
--
----------------------------------------------------------------

module Language.Hakaru.CodeGen.Libs
  ( -- math.h
    expE, expm1E, logE, log1pE, sqrtE,
    infinityE,negInfinityE,

    -- stdio.h
    printfE, sscanfE, fopenE, fcloseE, fileT, feofE, fgetsE, rewindE,

    -- stdlib.h
    randE, srandE, mallocE, freeE,

    -- Boehm Gargbage Collector
    gcHeader, gcInit, gcMalloc,

    -- OpenMP
    openMpHeader, ompGetNumThreads, ompGetThreadNum, OMP(..), Directive(..),
    ompToPP
  ) where

import Language.Hakaru.CodeGen.AST
import Language.Hakaru.CodeGen.Pretty
import Text.PrettyPrint (render)

{-

  As a convention to make the CExpressions standout, functions that return CExpr
  have a suffix 'E' for instance 'printfE'

-}


--------------------------------------------------------------------------------
--                                 Lib C                                      --
--------------------------------------------------------------------------------
{-
  Here we have calls to a very small subset of functionality provided by libc.
  In the future, we should have a standard way to add in bindings to C
  libraries. Easily generating code for existing C libraries is one of the key
  design goals of pedantic-c
-}

------------
-- math.h --
------------

expE,expm1E,logE,log1pE,sqrtE :: CExpr -> CExpr
expE :: CExpr -> CExpr
expE   = String -> CExpr -> CExpr
mkUnaryE String
"exp"
expm1E :: CExpr -> CExpr
expm1E = String -> CExpr -> CExpr
mkUnaryE String
"expm1"
logE :: CExpr -> CExpr
logE   = String -> CExpr -> CExpr
mkUnaryE String
"log"
log1pE :: CExpr -> CExpr
log1pE = String -> CExpr -> CExpr
mkUnaryE String
"log1p"
sqrtE :: CExpr -> CExpr
sqrtE  = String -> CExpr -> CExpr
mkUnaryE String
"sqrt"

infinityE,negInfinityE :: CExpr
infinityE :: CExpr
infinityE    = (Integer -> CExpr
intE Integer
1) CExpr -> CExpr -> CExpr
./. (Integer -> CExpr
intE Integer
0)
negInfinityE :: CExpr
negInfinityE = CExpr -> CExpr
logE (Integer -> CExpr
intE Integer
0)

--------------
-- stdlib.h --
--------------

randE :: CExpr
randE :: CExpr
randE = String -> [CExpr] -> CExpr
mkCallE String
"rand" []

srandE :: CExpr -> CExpr
srandE :: CExpr -> CExpr
srandE CExpr
e = String -> [CExpr] -> CExpr
mkCallE String
"srand" [CExpr
e]

mallocE :: CExpr -> CExpr
mallocE :: CExpr -> CExpr
mallocE = String -> CExpr -> CExpr
mkUnaryE String
"malloc"

freeE :: CExpr -> CExpr
freeE :: CExpr -> CExpr
freeE = String -> CExpr -> CExpr
mkUnaryE String
"free"

--------------
-- stdio.h --
--------------

printfE,sscanfE :: [CExpr] -> CExpr
printfE :: [CExpr] -> CExpr
printfE = String -> [CExpr] -> CExpr
mkCallE String
"printf"
sscanfE :: [CExpr] -> CExpr
sscanfE = String -> [CExpr] -> CExpr
mkCallE String
"sscanf"

fopenE :: CExpr -> CExpr -> CExpr
fopenE :: CExpr -> CExpr -> CExpr
fopenE CExpr
e0 CExpr
e1 = String -> [CExpr] -> CExpr
mkCallE String
"fopen" [CExpr
e0,CExpr
e1]

fcloseE,feofE,rewindE :: CExpr -> CExpr
fcloseE :: CExpr -> CExpr
fcloseE CExpr
e = String -> [CExpr] -> CExpr
mkCallE String
"fclose" [CExpr
e]
feofE :: CExpr -> CExpr
feofE CExpr
e = String -> [CExpr] -> CExpr
mkCallE String
"feof" [CExpr
e]
rewindE :: CExpr -> CExpr
rewindE CExpr
e = String -> [CExpr] -> CExpr
mkCallE String
"rewind" [CExpr
e]

fgetsE :: CExpr -> CExpr -> CExpr -> CExpr
fgetsE :: CExpr -> CExpr -> CExpr -> CExpr
fgetsE CExpr
e0 CExpr
e1 CExpr
e2 = String -> [CExpr] -> CExpr
mkCallE String
"fgets" [CExpr
e0,CExpr
e1,CExpr
e2]

fileT :: CTypeSpec
fileT :: CTypeSpec
fileT = Ident -> CTypeSpec
CTypeDefType (String -> Ident
Ident String
"FILE")

--------------------------------------------------------------------------------
--                            Boehm Garbage Collector                         --
--------------------------------------------------------------------------------
{-
   Currently needed for handling arrays and datum.

   In the future, an intermediate language based on the region calculus will be
   employed here.
-}

gcHeader :: Preprocessor
gcHeader :: Preprocessor
gcHeader = String -> Preprocessor
PPInclude String
"gc.h"

gcInit :: CExpr
gcInit :: CExpr
gcInit = String -> [CExpr] -> CExpr
mkCallE String
"GC_INIT" []

gcMalloc :: CExpr -> CExpr
gcMalloc :: CExpr -> CExpr
gcMalloc CExpr
e = String -> [CExpr] -> CExpr
mkCallE String
"GC_MALLOC" [CExpr
e]

--------------------------------------------------------------------------------
--                                  OpenMP                                    --
--------------------------------------------------------------------------------
{-
   For generating pragmas for shared memory parallelism, that is parallelism on
   on a single process that makes use of multithreaded processors. This
   interface is implemented in most C compilers and is accessed through pragmas

   This is a subset of the the OpenMP 4.5 standard.
-}

openMpHeader :: Preprocessor
openMpHeader :: Preprocessor
openMpHeader = String -> Preprocessor
PPInclude String
"omp.h"

ompGetNumThreads :: CExpr
ompGetNumThreads :: CExpr
ompGetNumThreads = String -> [CExpr] -> CExpr
mkCallE String
"omp_get_num_threads" []

ompGetThreadNum :: CExpr
ompGetThreadNum :: CExpr
ompGetThreadNum = String -> [CExpr] -> CExpr
mkCallE String
"omp_get_thread_num" []

data OMP = OMP Directive

data Directive
  = Parallel [Directive]
  | For
  | Critical
  | Reduction (Either CBinaryOp Ident) [CExpr]
  | DeclareRed Ident CTypeSpec CExpr CExpr

ompToPP :: OMP -> Preprocessor
ompToPP :: OMP -> Preprocessor
ompToPP (OMP Directive
d) = [String] -> Preprocessor
PPPragma ([String] -> Preprocessor) -> [String] -> Preprocessor
forall a b. (a -> b) -> a -> b
$ String
"omp"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:(Directive -> [String]
showDirective Directive
d)
  where showDirective :: Directive -> [String]
        showDirective :: Directive -> [String]
showDirective (Parallel [Directive]
ds)      = String
"parallel"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:((Directive -> [String]) -> [Directive] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Directive -> [String]
showDirective [Directive]
ds)
        showDirective Directive
For                = [String
"for"]
        showDirective Directive
Critical           = [String
"critical"]
        showDirective (Reduction Either CBinaryOp Ident
eop [CExpr]
vs) =
          let op :: String
op = case Either CBinaryOp Ident
eop of
                     Left CBinaryOp
binop -> Doc -> String
render (Doc -> String) -> (CBinaryOp -> Doc) -> CBinaryOp -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CBinaryOp -> Doc
forall a. Pretty a => a -> Doc
pretty (CBinaryOp -> String) -> CBinaryOp -> String
forall a b. (a -> b) -> a -> b
$ CBinaryOp
binop
                     Right (Ident String
s) -> String
s
          in  [String
"reduction(",String
op,String
":",[String] -> String
unwords ([String] -> String) -> ([CExpr] -> [String]) -> [CExpr] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CExpr -> String) -> [CExpr] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc -> String
render(Doc -> String) -> (CExpr -> Doc) -> CExpr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty) ([CExpr] -> String) -> [CExpr] -> String
forall a b. (a -> b) -> a -> b
$ [CExpr]
vs,String
")"]
        showDirective (DeclareRed (Ident String
name) CTypeSpec
typ CExpr
mul CExpr
unit) =
          let typ' :: String
typ'  = Doc -> String
render (Doc -> String) -> (CTypeSpec -> Doc) -> CTypeSpec -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTypeSpec -> Doc
forall a. Pretty a => a -> Doc
pretty (CTypeSpec -> String) -> CTypeSpec -> String
forall a b. (a -> b) -> a -> b
$ CTypeSpec
typ
              mul' :: String
mul'  = Doc -> String
render (Doc -> String) -> (CExpr -> Doc) -> CExpr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty (CExpr -> String) -> CExpr -> String
forall a b. (a -> b) -> a -> b
$ CExpr
mul
              unit' :: String
unit' = Doc -> String
render (Doc -> String) -> (CExpr -> Doc) -> CExpr -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CExpr -> Doc
forall a. Pretty a => a -> Doc
pretty (CExpr -> String) -> CExpr -> String
forall a b. (a -> b) -> a -> b
$ CExpr
unit
          in [String
"declare",String
"reduction(",String
name,String
":",String
typ',String
":",String
mul',String
") initializer ("
             ,String
unit',String
")"]