2 files changed, 135 insertions, 0 deletions
diff --git a/Data/Array/Accelerate/C.hs b/Data/Array/Accelerate/C.hs
new file mode 100644
index 0000000..faa06f1
--- /dev/null
+++ b/Data/Array/Accelerate/C.hs
@@ -0,0 +1,76 @@
+{-|
+Module      : Data.Array.Accelerate.C
+Description : Sequential C backend for Accelerate
+Copyright   : (c) Tom Smeding, 2021
+License     : MIT
+Maintainer  : x+accelerate@tomsmeding.com
+Stability   : experimental
+Portability : non-portable (GHC extensions)
+
+This is a sequential C backend to Accelerate.
+
+Arrays are flattened in the C code: a two-dimensional array with elements of
+type @Float@ is encoded as a row-major single-dimensional array of type
+@float*@ in C. The indexing is the same as for the @linearIndex@ function from
+Accelerate.
+
+Because of the choices made in representing arrays as arguments to the
+generated C functions, using this backend may require a (basic) understanding
+of how Accelerate internally represents arrays (i.e. the so-called
+/representation types/). However, this only really becomes relevant if you use
+self-defined data types or sum types like @Maybe@, since otherwise it should be
+intuitive enough for casual use. These representation types show up in the
+precise form of the argument and output variable descriptors ('CArrTupNames')
+returned by 'translateAcc', and they influence the ordering of the arguments to the
+C functions.
+-}
+module Data.Array.Accelerate.C (
+    translateAcc,
+    CArrTupNames(..), CShNames(..), CArrNames(..),
+    C.Name(..), C.Type(..), C.Bits(..),
+) where
+
+import qualified Data.Array.Accelerate.Smart as Smart
+import qualified Data.Array.Accelerate.Sugar.Array as A
+import qualified Data.Array.Accelerate.Trafo as A
+
+import Data.Array.Accelerate.Trafo.UnDelayed
+import qualified Language.C as C
+import Language.C.Print (printProgram)
+import SC.Afun
+import SC.Prelude
+import SC.Monad
+
+
+-- | The function passed should have exactly one argument (that may consist of
+-- multiple arrays in a tuple, of course). The string argument determines the
+-- name of the top-level generated C function.
+--
+-- The result consists of:
+--
+-- 1. C source code (including required prelude) defining, ultimately, a C
+--    function that implements the top-level Accelerate array function.
+-- 2. The variable names corresponding to the components of the argument of the
+--    top-level function.
+-- 3. The variable names corresponding to the components of the result of the
+--    top-level function. These are out-arguments (i.e. pointer arguments) to
+--    that function.
+--
+-- For an example of how the produced function looks and how the variable name
+-- containers describe its arguments, see the documentation of 'CArrTupNames'.
+--
+-- Note that the variable name descriptors refer to the /representation types/
+-- of the input and output of the array function. This essentially means that
+-- the type has been converted to a form using only pairs and arrays. (This is
+-- the internal representation of data types in Accelerate.)
+translateAcc :: (A.Arrays a, A.Arrays b)
+             => String
+             -> (Smart.Acc a -> Smart.Acc b)
+             -> Either String (String, CArrTupNames (A.ArraysR a), CArrTupNames (A.ArraysR b))
+translateAcc procname afun = do
+    let ast = unDelayedAfun (A.convertAfun afun)
+    (auxdefs, fundef, argnames, outnames) <- evalSC (compileAfun1 (C.Name procname) ast)
+    let program = C.Program (auxdefs ++ [fundef])
+    return (prelude ++ "\n" ++ printProgram program 0 ""
+           ,argnames
+           ,outnames)
diff --git a/Data/Array/Accelerate/Trafo/UnDelayed.hs b/Data/Array/Accelerate/Trafo/UnDelayed.hs
new file mode 100644
index 0000000..8553dfa
--- /dev/null
+++ b/Data/Array/Accelerate/Trafo/UnDelayed.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+module Data.Array.Accelerate.Trafo.UnDelayed (
+  unDelayed, unDelayedAfun
+) where
+
+import Data.Array.Accelerate.AST
+import Data.Array.Accelerate.Trafo.Delayed
+
+
+-- | Convert from a delayed Acc representation back to the pre-fusion, internal
+-- Acc representation. This forgets information about whether nodes are
+-- manifest or not.
+unDelayed :: DelayedOpenAcc aenv a -> OpenAcc aenv a
+unDelayed (Manifest acc) = OpenAcc (unDelayed `through` acc)
+unDelayed (Delayed repr shexp fun _) = unDelayed (Manifest (Generate repr shexp fun))
+
+unDelayedAfun :: DelayedOpenAfun aenv a -> OpenAfun aenv a
+unDelayedAfun (Alam lhs fun) = Alam lhs (unDelayedAfun fun)
+unDelayedAfun (Abody a) = Abody (unDelayed a)
+
+through :: (forall aenv' t. f aenv' t -> g aenv' t)
+        -> PreOpenAcc f aenv a
+        -> PreOpenAcc g aenv a
+through f = \case
+  Alet lhs rhs body -> Alet lhs (f rhs) (f body)
+  Avar var -> Avar var
+  Apair a1 a2 -> Apair (f a1) (f a2)
+  Anil -> Anil
+  Apply ty fun a -> Apply ty (f `throughAF` fun) (f a)
+  Aforeign ty asm fun a -> Aforeign ty asm (f `throughAF` fun) (f a)
+  Acond e a1 a2 -> Acond e (f a1) (f a2)
+  Awhile fun1 fun2 a -> Awhile (f `throughAF` fun1) (f `throughAF` fun2) (f a)
+  Use ty arr -> Use ty arr
+  Unit ety e -> Unit ety e
+  Reshape sht e a -> Reshape sht e (f a)
+  Generate ty e efun -> Generate ty e efun
+  Transform ty e efun1 efun2 a -> Transform ty e efun1 efun2 (f a)
+  Replicate slix e a -> Replicate slix e (f a)
+  Slice slix a e -> Slice slix (f a) e
+  Map ty fun a -> Map ty fun (f a)
+  ZipWith ty fun a1 a2 -> ZipWith ty fun (f a1) (f a2)
+  Fold efun me a -> Fold efun me (f a)
+  FoldSeg ety efun me a1 a2 -> FoldSeg ety efun me (f a1) (f a2)
+  Scan dir efun me a -> Scan dir efun me (f a)
+  Scan' dir efun e a -> Scan' dir efun e (f a)
+  Permute efun1 a1 efun2 a2 -> Permute efun1 (f a1) efun2 (f a2)
+  Backpermute sht e efun a -> Backpermute sht e efun (f a)
+  Stencil stty ety efun bnd a -> Stencil stty ety efun bnd (f a)
+  Stencil2 stty1 stty2 ety efun bnd1 a1 bnd2 a2 ->
+    Stencil2 stty1 stty2 ety efun bnd1 (f a1) bnd2 (f a2)
+
+throughAF :: (forall aenv' t. f aenv' t -> g aenv' t)
+          -> PreOpenAfun f aenv a
+          -> PreOpenAfun g aenv a
+throughAF f = \case
+  Abody a -> Abody (f a)
+  Alam lhs fun -> Alam lhs (f `throughAF` fun)