{-# LANGUAGE QuasiQuotes #-}

-- | C code generator.  This module can convert a correct ImpCode
-- program to an equivalent C program. The C code is strictly
-- sequential, but can handle the full Futhark language.
module Futhark.CodeGen.Backends.SequentialC
  ( compileProg,
    GC.CParts (..),
    GC.asLibrary,
    GC.asExecutable,
  )
where

import Control.Monad
import qualified Futhark.CodeGen.Backends.GenericC as GC
import qualified Futhark.CodeGen.ImpCode.Sequential as Imp
import qualified Futhark.CodeGen.ImpGen.Sequential as ImpGen
import Futhark.IR.SeqMem
import Futhark.MonadFreshNames
import qualified Language.C.Quote.OpenCL as C

-- | Compile the program to sequential C.
compileProg :: MonadFreshNames m => Prog SeqMem -> m (ImpGen.Warnings, GC.CParts)
compileProg :: Prog SeqMem -> m (Warnings, CParts)
compileProg =
  (Definitions Sequential -> m CParts)
-> (Warnings, Definitions Sequential) -> m (Warnings, CParts)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse
    (String
-> Operations Sequential ()
-> CompilerM Sequential () ()
-> String
-> [Space]
-> [Option]
-> Definitions Sequential
-> m CParts
forall (m :: * -> *) op.
MonadFreshNames m =>
String
-> Operations op ()
-> CompilerM op () ()
-> String
-> [Space]
-> [Option]
-> Definitions op
-> m CParts
GC.compileProg String
"c" Operations Sequential ()
operations CompilerM Sequential () ()
forall op s. CompilerM op s ()
generateContext String
"" [Space
DefaultSpace] [])
    ((Warnings, Definitions Sequential) -> m (Warnings, CParts))
-> (Prog SeqMem -> m (Warnings, Definitions Sequential))
-> Prog SeqMem
-> m (Warnings, CParts)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Prog SeqMem -> m (Warnings, Definitions Sequential)
forall (m :: * -> *).
MonadFreshNames m =>
Prog SeqMem -> m (Warnings, Definitions Sequential)
ImpGen.compileProg
  where
    operations :: GC.Operations Imp.Sequential ()
    operations :: Operations Sequential ()
operations =
      Operations Sequential ()
forall op s. Operations op s
GC.defaultOperations
        { opsCompiler :: OpCompiler Sequential ()
GC.opsCompiler = CompilerM Sequential () () -> OpCompiler Sequential ()
forall a b. a -> b -> a
const (CompilerM Sequential () () -> OpCompiler Sequential ())
-> CompilerM Sequential () () -> OpCompiler Sequential ()
forall a b. (a -> b) -> a -> b
$ () -> CompilerM Sequential () ()
forall (m :: * -> *) a. Monad m => a -> m a
return (),
          opsCopy :: Copy Sequential ()
GC.opsCopy = Copy Sequential ()
copySequentialMemory
        }

    generateContext :: CompilerM op s ()
generateContext = do
      String
cfg <- String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s String
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s String
GC.publicDef String
"context_config" HeaderSection
GC.InitDecl ((String -> (Definition, Definition)) -> CompilerM op s String)
-> (String -> (Definition, Definition)) -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ \String
s ->
        ( [C.cedecl|struct $id:s;|],
          [C.cedecl|struct $id:s { int debugging; };|]
        )

      String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ String
"context_config_new" HeaderSection
GC.InitDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
        ( [C.cedecl|struct $id:cfg* $id:s(void);|],
          [C.cedecl|struct $id:cfg* $id:s(void) {
                                 struct $id:cfg *cfg = (struct $id:cfg*) malloc(sizeof(struct $id:cfg));
                                 if (cfg == NULL) {
                                   return NULL;
                                 }
                                 cfg->debugging = 0;
                                 return cfg;
                               }|]
        )

      String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ String
"context_config_free" HeaderSection
GC.InitDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
        ( [C.cedecl|void $id:s(struct $id:cfg* cfg);|],
          [C.cedecl|void $id:s(struct $id:cfg* cfg) {
                                 free(cfg);
                               }|]
        )

      String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ String
"context_config_set_debugging" HeaderSection
GC.InitDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
        ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|],
          [C.cedecl|void $id:s(struct $id:cfg* cfg, int detail) {
                          cfg->debugging = detail;
                        }|]
        )

      String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ String
"context_config_set_logging" HeaderSection
GC.InitDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
        ( [C.cedecl|void $id:s(struct $id:cfg* cfg, int flag);|],
          [C.cedecl|void $id:s(struct $id:cfg* cfg, int detail) {
                                 /* Does nothing for this backend. */
                                 (void)cfg; (void)detail;
                               }|]
        )

      ([FieldGroup]
fields, [Stm]
init_fields) <- CompilerM op s ([FieldGroup], [Stm])
forall op s. CompilerM op s ([FieldGroup], [Stm])
GC.contextContents

      String
ctx <- String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s String
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s String
GC.publicDef String
"context" HeaderSection
GC.InitDecl ((String -> (Definition, Definition)) -> CompilerM op s String)
-> (String -> (Definition, Definition)) -> CompilerM op s String
forall a b. (a -> b) -> a -> b
$ \String
s ->
        ( [C.cedecl|struct $id:s;|],
          [C.cedecl|struct $id:s {
                          int detail_memory;
                          int debugging;
                          int profiling;
                          typename lock_t lock;
                          char *error;
                          int profiling_paused;
                          $sdecls:fields
                        };|]
        )

      String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ String
"context_new" HeaderSection
GC.InitDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
        ( [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg);|],
          [C.cedecl|struct $id:ctx* $id:s(struct $id:cfg* cfg) {
                                  struct $id:ctx* ctx = (struct $id:ctx*) malloc(sizeof(struct $id:ctx));
                                  if (ctx == NULL) {
                                    return NULL;
                                  }
                                  ctx->detail_memory = cfg->debugging;
                                  ctx->debugging = cfg->debugging;
                                  ctx->profiling = cfg->debugging;
                                  ctx->error = NULL;
                                  create_lock(&ctx->lock);
                                  $stms:init_fields
                                  init_constants(ctx);
                                  return ctx;
                               }|]
        )

      String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ String
"context_free" HeaderSection
GC.InitDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
        ( [C.cedecl|void $id:s(struct $id:ctx* ctx);|],
          [C.cedecl|void $id:s(struct $id:ctx* ctx) {
                                 free_constants(ctx);
                                 free_lock(&ctx->lock);
                                 free(ctx);
                               }|]
        )

      String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ String
"context_sync" HeaderSection
GC.MiscDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
        ( [C.cedecl|int $id:s(struct $id:ctx* ctx);|],
          [C.cedecl|int $id:s(struct $id:ctx* ctx) {
                                 (void)ctx;
                                 return 0;
                               }|]
        )

      String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
forall op s.
String
-> HeaderSection
-> (String -> (Definition, Definition))
-> CompilerM op s ()
GC.publicDef_ String
"context_clear_caches" HeaderSection
GC.MiscDecl ((String -> (Definition, Definition)) -> CompilerM op s ())
-> (String -> (Definition, Definition)) -> CompilerM op s ()
forall a b. (a -> b) -> a -> b
$ \String
s ->
        ( [C.cedecl|int $id:s(struct $id:ctx* ctx);|],
          [C.cedecl|int $id:s(struct $id:ctx* ctx) {
                                 (void)ctx;
                                 return 0;
                               }|]
        )

copySequentialMemory :: GC.Copy Imp.Sequential ()
copySequentialMemory :: Copy Sequential ()
copySequentialMemory Exp
destmem Exp
destidx Space
DefaultSpace Exp
srcmem Exp
srcidx Space
DefaultSpace Exp
nbytes =
  Exp -> Exp -> Exp -> Exp -> Exp -> CompilerM Sequential () ()
forall op s. Exp -> Exp -> Exp -> Exp -> Exp -> CompilerM op s ()
GC.copyMemoryDefaultSpace Exp
destmem Exp
destidx Exp
srcmem Exp
srcidx Exp
nbytes
copySequentialMemory Exp
_ Exp
_ Space
destspace Exp
_ Exp
_ Space
srcspace Exp
_ =
  String -> CompilerM Sequential () ()
forall a. HasCallStack => String -> a
error (String -> CompilerM Sequential () ())
-> String -> CompilerM Sequential () ()
forall a b. (a -> b) -> a -> b
$ String
"Cannot copy to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Space -> String
forall a. Show a => a -> String
show Space
destspace String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Space -> String
forall a. Show a => a -> String
show Space
srcspace