Clerk: compilation to C

build_system/clerk_driver.ml

@@ -433,6 +433,9 @@ module Poll = struct
 
   let ocaml_link_flags : string list Lazy.t =
     lazy (snd (Lazy.force ocaml_include_and_lib_flags))
+
+  let c_runtime_dir : File.t Lazy.t =
+    lazy File.(Lazy.force ocaml_runtime_dir /../ "runtime_c")
 end
 
 (**{1 Building rules}*)
@@ -449,12 +452,16 @@ module Var = struct
   let catala_exe = make "CATALA_EXE"
   let catala_flags = make "CATALA_FLAGS"
   let catala_flags_ocaml = make "CATALA_FLAGS_OCAML"
+  let catala_flags_c = make "CATALA_FLAGS_C"
   let catala_flags_python = make "CATALA_FLAGS_PYTHON"
   let clerk_flags = make "CLERK_FLAGS"
   let ocamlc_exe = make "OCAMLC_EXE"
   let ocamlopt_exe = make "OCAMLOPT_EXE"
   let ocaml_flags = make "OCAML_FLAGS"
   let runtime_ocaml_libs = make "RUNTIME_OCAML_LIBS"
+  let cc_exe = make "CC"
+  let c_flags = make "CFLAGS"
+  let runtime_c_libs = make "RUNTIME_C_LIBS"
 
   (** Rule vars, Used in specific rules *)
 
@@ -484,6 +491,9 @@ let base_bindings catala_exe catala_flags build_dir include_dirs test_flags =
         | "-O" | "--optimize" | "--closure-conversion" -> true | _ -> false)
       test_flags
   in
+  let catala_flags_c =
+    List.filter (function "-O" | "--optimize" -> true | _ -> false) test_flags
+  in
   let catala_flags_python =
     List.filter
       (function
@@ -504,6 +514,7 @@ let base_bindings catala_exe catala_flags build_dir include_dirs test_flags =
       ];
     Nj.binding Var.catala_flags (catala_flags @ includes);
     Nj.binding Var.catala_flags_ocaml catala_flags_ocaml;
+    Nj.binding Var.catala_flags_c catala_flags_c;
     Nj.binding Var.catala_flags_python catala_flags_python;
     Nj.binding Var.clerk_flags
       ("-e"
@@ -515,6 +526,25 @@ let base_bindings catala_exe catala_flags build_dir include_dirs test_flags =
     Nj.binding Var.ocamlopt_exe ["ocamlopt"];
     Nj.binding Var.ocaml_flags (ocaml_flags @ includes);
     Nj.binding Var.runtime_ocaml_libs (Lazy.force Poll.ocaml_link_flags);
+    Nj.binding Var.cc_exe ["cc"];
+    Nj.binding Var.runtime_c_libs
+      [
+        "-I" ^ Lazy.force Poll.c_runtime_dir;
+        "-L" ^ Lazy.force Poll.c_runtime_dir;
+        "-lcatala_runtime";
+        "-lgmp";
+      ];
+    Nj.binding Var.c_flags
+      ([
+         "-std=c89";
+         "-pedantic";
+         "-Wall";
+         "-Wno-unused-function";
+         "-Wno-unused-variable";
+         "-Werror";
+         Var.(!runtime_c_libs);
+       ]
+      @ includes);
   ]
 
 let[@ocamlformat "disable"] static_base_rules =
@@ -552,6 +582,25 @@ let[@ocamlformat "disable"] static_base_rules =
       ]
       ~description:["<ocaml>"; "⇒"; !output];
 
+    Nj.rule "catala-c"
+      ~command:[!catala_exe; "c"; !catala_flags; !catala_flags_c;
+                !input; "-o"; !output]
+      ~description:["<catala>"; "c"; "⇒"; !output];
+
+    Nj.rule "c-object"
+      ~command:
+        [!cc_exe; !input; !c_flags; "-c"; "-o"; !output]
+      ~description:["<cc>"; "⇒"; !output];
+
+    Nj.rule "c-exec"
+      ~command: [
+        !cc_exe;
+        shellout [!catala_exe; "depends";
+                  "--prefix="^ !builddir; "--extension=c.o";
+                  !catala_flags; !orig_src];
+        !input; !c_flags; "-o"; !output]
+      ~description:["<cc>"; "⇒"; !output];
+
     Nj.rule "python"
       ~command:[!catala_exe; "python"; !catala_flags; !catala_flags_python;
                 !input; "-o"; !output]
@@ -607,12 +656,25 @@ let gen_build_statements
   in
   let ml_file = target_file "ml" in
   let py_file = target_file "py" in
-  let ocaml, python =
+  let c_file = target_file "c" in
+  let h_file = target_file "h" in
+  let ocaml, c, python =
     if item.extrnal then
       ( Nj.build "copy"
           ~implicit_in:[inc srcv]
           ~inputs:[src -.- "ml"]
           ~outputs:[ml_file],
+        List.to_seq
+          [
+            Nj.build "copy"
+              ~implicit_in:[inc srcv]
+              ~inputs:[src -.- "c"]
+              ~outputs:[c_file];
+            Nj.build "copy"
+              ~implicit_in:[inc srcv]
+              ~inputs:[src -.- "h"]
+              ~outputs:[h_file];
+          ],
         Nj.build "copy"
           ~implicit_in:[inc srcv]
           ~inputs:[src -.- "py"]
@@ -621,6 +683,11 @@ let gen_build_statements
       ( Nj.build "catala-ocaml"
           ~inputs:[inc srcv]
           ~implicit_in:[!Var.catala_exe] ~outputs:[ml_file],
+        Seq.return
+          (Nj.build "catala-c"
+             ~inputs:[inc srcv]
+             ~implicit_in:[!Var.catala_exe] ~outputs:[c_file]
+             ~implicit_out:[h_file]),
         Nj.build "python"
           ~inputs:[inc srcv]
           ~implicit_in:[!Var.catala_exe] ~outputs:[py_file] )
@@ -659,11 +726,30 @@ let gen_build_statements
     in
     [obj; modexec]
   in
+  let cc =
+    Nj.build "c-object" ~inputs:[c_file]
+      ~implicit_in:(!Var.catala_exe :: h_file :: List.map (modfile ".h") modules)
+      ~outputs:[target_file "c.o"]
+    ::
+    (if item.module_def <> None then []
+     else
+       [
+         Nj.build "c-exec"
+           ~implicit_in:(target_file "c.o" :: List.map (modfile ".c.o") modules)
+           ~outputs:[target_file "c.exe"]
+           ~vars:[Var.orig_src, [inc srcv]];
+       ])
+  in
   let expose_module =
     match item.module_def with
     | Some m when List.mem (dirname src) include_dirs ->
-      Some (Nj.build "phony" ~outputs:[m ^ "@module"] ~inputs:[modd m])
-    | _ -> None
+      [
+        Nj.build "phony" ~outputs:[m ^ "@module"] ~inputs:[modd m];
+        Nj.build "phony"
+          ~outputs:[m ^ ".h"; m ^ ".c.o"]
+          ~inputs:[modfile ".h" m; modfile ".c.o" m];
+      ]
+    | _ -> []
   in
   let interp_deps =
     !Var.catala_exe
@@ -715,9 +801,11 @@ let gen_build_statements
          Seq.return def_src;
          Seq.return include_deps;
          Option.to_seq module_deps;
-         Option.to_seq expose_module;
+         List.to_seq expose_module;
          Seq.return ocaml;
          List.to_seq ocamlopt;
+         c;
+         List.to_seq cc;
          Seq.return python;
          List.to_seq tests;
          Seq.return interpret;

compiler/scalc/to_c.ml

@@ -145,10 +145,8 @@ let rec format_typ
   | TAny -> Format.fprintf fmt "%svoid * /* any */%t" sconst element_name
   | TClosureEnv -> Format.fprintf fmt "%sCLOSURE_ENV%t" sconst element_name
 
-let format_ctx
-    (type_ordering : TypeIdent.t list)
-    ~ppc ~pph
-    (ctx : decl_ctx) : unit =
+let format_ctx (type_ordering : TypeIdent.t list) ~ppc ~pph (ctx : decl_ctx) :
+    unit =
   let format_struct_decl fmt (struct_name, struct_fields) =
     let fields = StructField.Map.bindings struct_fields in
     if fields = [] then
@@ -194,7 +192,8 @@ let format_ctx
       (EnumName.base enum_name)
   in
   let scope_structs =
-    List.fold_left (fun acc -> function
+    List.fold_left
+      (fun acc -> function
         | TypeIdent.Struct s -> StructName.Map.remove s acc
         | _ -> acc)
       ctx.ctx_structs type_ordering
@@ -205,20 +204,17 @@ let format_ctx
     (fun struct_or_enum ->
       match struct_or_enum with
       | TypeIdent.Struct s as tid ->
-        if StructName.path s = [] then
+        if StructName.path s = [] then (
           let def = StructName.Map.find s ctx.ctx_structs in
           Format.fprintf ppc "@,%a" format_struct_decl (s, def);
-          if TypeIdent.Set.mem tid ctx.ctx_public_types
-          then Format.fprintf pph "@,%a" format_struct_decl (s, def)
-          else Format.eprintf "NOT PUB: %a (pub: %a)@."
-              StructName.format s
-              (Format.pp_print_seq ~pp_sep:Format.pp_print_space TypeIdent.format) (TypeIdent.Set.to_seq ctx.ctx_public_types)
+          if TypeIdent.Set.mem tid ctx.ctx_public_types then
+            Format.fprintf pph "@,%a" format_struct_decl (s, def))
       | TypeIdent.Enum e as tid ->
-        if EnumName.path e = [] then
+        if EnumName.path e = [] then (
           let def = EnumName.Map.find e ctx.ctx_enums in
           Format.fprintf ppc "@,%a" format_enum_decl (e, def);
-          if TypeIdent.Set.mem tid ctx.ctx_public_types
-          then Format.fprintf pph "@,%a" format_enum_decl (e, def))
+          if TypeIdent.Set.mem tid ctx.ctx_public_types then
+            Format.fprintf pph "@,%a" format_enum_decl (e, def)))
     (type_ordering @ scope_structs)
 
 let format_lit (fmt : Format.formatter) (l : lit Mark.pos) : unit =
@@ -554,7 +550,7 @@ let rec format_statement
       cases
       (EnumConstructor.Map.bindings
          (EnumName.Map.find e_name ctx.decl_ctx.ctx_enums));
-    (* Do we want to add 'default' case with a failure ? *)
+    Format.fprintf fmt "@,@[<v 2>default:@,abort();@]";
     Format.fprintf fmt "@;<0 -2>}";
     Format.pp_close_box fmt ()
   | SReturn e1 ->
@@ -662,7 +658,7 @@ and format_block (ctx : ctx) (env : env) (fmt : Format.formatter) (b : block) :
     in
     Option.iter (format_statement ctx env fmt) pos_def;
     format_statement ctx env fmt fatal;
-    Format.fprintf fmt "@,return NULL;" (* unreachable, but avoids a warning *)
+    Format.fprintf fmt "@,abort();" (* unreachable, but avoids a warning *)
   | _ ->
     let remaining =
       format_decls (VarName.Set.union env.global_vars env.local_vars) [] b
@@ -713,28 +709,38 @@ let format_program
     ~ppf_intf:pph
     (p : Ast.program)
     (type_ordering : TypeIdent.t list) : unit =
-  let ppboth f = f ppc; f pph in
-  let ppboth_if condition f = f ppc; if condition then f pph in
-  Fun.protect ~finally:(fun () -> ppboth (fun ppf -> Format.pp_print_newline ppf ()))
+  let ppboth f =
+    f ppc;
+    f pph
+  in
+  let ppboth_if condition f =
+    f ppc;
+    if condition then f pph
+  in
+  Fun.protect ~finally:(fun () ->
+      ppboth (fun ppf -> Format.pp_print_newline ppf ()))
   @@ fun () ->
   ppboth (fun ppf -> Format.pp_open_vbox ppf 0);
-  ppboth (fun ppf -> Format.fprintf ppf
-             "/* This file has been generated by the Catala compiler, do not edit! */@,@,");
+  ppboth (fun ppf ->
+      Format.fprintf ppf
+        "/* This file has been generated by the Catala compiler, do not edit! \
+         */@,\
+         @,");
   Format.fprintf ppc
-    "#include <stdio.h>@,\
-     #include <stdlib.h>@,\
-     #include <catala_runtime.h>@,\
-     @,";
+    "#include <stdio.h>@,#include <stdlib.h>@,#include <catala_runtime.h>@,@,";
   let module_id =
     match p.module_name with
     | None -> "MAIN"
-    | Some (m, _) -> String.uppercase_ascii (String.to_ascii (ModuleName.to_string m))
+    | Some (m, _) ->
+      String.uppercase_ascii (String.to_ascii (ModuleName.to_string m))
   in
   Format.fprintf pph "#ifndef __%s_H__@,#define __%s_H__@," module_id module_id;
   List.iter
     (fun (m, _intf_id) ->
-       ppboth @@ fun ppf -> Format.fprintf ppf "@,#include \"%s.h\""
-         (String.uncapitalize_ascii (ModuleName.to_string m)))
+      ppboth
+      @@ fun ppf ->
+      Format.fprintf ppf "@,#include <%s.h>"
+        ((* String.uncapitalize_ascii *) ModuleName.to_string m))
     (Program.modules_to_list p.ctx.decl_ctx.ctx_modules);
   (* TODO: check the module hash ? *)
   format_ctx type_ordering ~ppc ~pph p.ctx.decl_ctx;
@@ -749,12 +755,16 @@ let format_program
              parameters that perform lazy evaluation: {[ inline foo_type foo() {
              static foo_type foo = NULL; return (foo ? foo : foo = foo_init());
              } ]} NOTE: "inline" is not defined in C89 *)
-          let public = (* TODO: Ugh! Pass this info into scalc ! *)
-            Re.(execp (compile (seq [str "__"; diff any digit])) (VarName.to_string var))
+          let public =
+            (* TODO: Ugh! Pass this info into scalc ! *)
+            Re.(
+              execp
+                (compile (seq [str "__"; diff any digit]))
+                (VarName.to_string var))
           in
           ppboth_if public (fun ppf ->
               Format.fprintf ppf "@,@[<v 2>@[<hov 4>%s%a"
-                (if public then "" else "static ")
+                (if public then "" else "static")
                 (format_typ ~const:true p.ctx.decl_ctx (fun fmt ->
                      Format.pp_print_space fmt ();
                      VarName.format fmt var))
@@ -779,12 +789,16 @@ let format_program
             VarName.Set.of_list
               (List.map (fun (v, _) -> Mark.remove v) func_params)
           in
-          let public = (* TODO: Ugh! Pass this info into scalc ! *)
-            Re.(execp (compile (seq [str "__"; diff any digit])) (FuncName.to_string var))
+          let public =
+            (* TODO: Ugh! Pass this info into scalc ! *)
+            Re.(
+              execp
+                (compile (seq [str "__"; diff any digit]))
+                (FuncName.to_string var))
           in
           ppboth_if public (fun ppf ->
-              Format.fprintf ppf
-                "@,@[<v 2>@[<hov 4>%a@ @[<hv 1>(%a)@]@]"
+              Format.fprintf ppf "@,@[<v 2>@[<hov 4>%s%a@ @[<hv 1>(%a)@]@]"
+                (if public then "" else "static ")
                 (format_typ ~const:true ctx.decl_ctx (fun fmt ->
                      Format.pp_print_space fmt ();
                      FuncName.format fmt var))
@@ -792,12 +806,12 @@ let format_program
                 (Format.pp_print_list
                    ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
                    (fun fmt (var, typ) ->
-                      Format.pp_open_hovbox fmt 2;
-                      (format_typ ~const:true p.ctx.decl_ctx (fun fmt ->
-                           Format.pp_print_space fmt ();
-                           VarName.format fmt (Mark.remove var)))
-                        fmt typ;
-                      Format.pp_close_box fmt ()))
+                     Format.pp_open_hovbox fmt 2;
+                     (format_typ ~const:true p.ctx.decl_ctx (fun fmt ->
+                          Format.pp_print_space fmt ();
+                          VarName.format fmt (Mark.remove var)))
+                       fmt typ;
+                     Format.pp_close_box fmt ()))
                 func_params);
           if public then Format.fprintf pph "@];@,";
           Format.fprintf ppc "@;<1 -2>{%a@]@,}@,"

runtimes/c/dune

@@ -10,3 +10,8 @@
  (target catala_runtime.a)
  (action
   (run ar rcs %{target} %{lib:dates_calc:c/dates_calc.o} %{deps})))
+
+(rule
+ (target dates_calc.h)
+ (action
+  (copy %{lib:dates_calc:c/dates_calc.h} %{target})))

runtimes/dune

@@ -26,5 +26,6 @@
 (install
  (files
   (c/catala_runtime.a as runtime_c/libcatala_runtime.a)
+  (c/dates_calc.h as runtime_c/dates_calc.h)
   (c/runtime.h as runtime_c/catala_runtime.h))
  (section lib))

tests/backends/output/simple.c

@@ -5,6 +5,7 @@
 #include <catala_runtime.h>
 
 
+
 typedef struct Foo {
   CATALA_BOOL x;
   CATALA_DEC y;
@@ -15,16 +16,16 @@ typedef struct Baz {
   const CATALA_ARRAY(CATALA_DEC) c;
 } Baz;
 
-enum Bar_code {
-  Bar_No,
-  Bar_Yes
-} Bar_code;
+enum Bar__code {
+  NO,
+  YES
+};
 
 typedef struct Bar {
-  enum Bar_code code;
+  enum Bar__code code;
   union {
-    CATALA_UNIT No;
-    const Foo* Yes;
+    CATALA_UNIT NO;
+    const Foo* YES;
   } payload;
 } Bar;
 
@@ -32,7 +33,7 @@ typedef struct Baz_in {
   const catala_closure* a_in;
 } Baz_in;
 
-const Baz* baz (const Baz_in* baz_in)
+static const Baz* baz (const Baz_in* baz_in)
 {
   const catala_closure* a = baz_in->a_in;
   const Bar* a__1;
@@ -55,8 +56,8 @@ const Baz* baz (const Baz_in* baz_in)
     const Bar* a__4;
     Bar* const a__6 = catala_malloc(sizeof(Bar));
     const CATALA_OPTION(Bar*) a__5;
-    a__6->code = Bar_No;
-    a__6->payload.No = CATALA_UNITVAL;
+    a__6->code = NO;
+    a__6->payload.NO = CATALA_UNITVAL;
     a__5 = catala_some(a__6);
     if (a__5->code == catala_option_some) {
       a__4 = a__5->payload;
@@ -64,7 +65,7 @@ const Baz* baz (const Baz_in* baz_in)
       static const catala_code_position pos[1] =
         {{"tests/backends/simple.catala_en", 11, 11, 11, 12}};
       catala_error(catala_no_value, pos);
-      return NULL;
+      abort();
     }
     a__2 = catala_some(a__4);
   }
@@ -74,17 +75,19 @@ const Baz* baz (const Baz_in* baz_in)
     static const catala_code_position pos[1] =
       {{"tests/backends/simple.catala_en", 11, 11, 11, 12}};
     catala_error(catala_no_value, pos);
-    return NULL;
+    abort();
   }
   switch (a__1->code) {
-    case Bar_No: {
+    case NO: {
       b__3 = CATALA_TRUE;
       break;
     }
-    case Bar_Yes: {
+    case YES: {
       b__3 = CATALA_FALSE;
       break;
     }
+    default:
+      abort();
   }
   if (b__3 == CATALA_TRUE) {
     b__2 = catala_some(catala_new_dec_str("42"));
@@ -96,12 +99,12 @@ const Baz* baz (const Baz_in* baz_in)
   } else {
     CATALA_DEC b__4;
     switch (a__1->code) {
-      case Bar_No: {
+      case NO: {
         b__4 = catala_new_dec_str("0");
         break;
       }
-      case Bar_Yes: {
-        const Foo* foo = a__1->payload.Yes;
+      case YES: {
+        const Foo* foo = a__1->payload.YES;
         CATALA_DEC b__5;
         if (foo->x == CATALA_TRUE) {
           b__5 = catala_new_dec_str("1");
@@ -111,6 +114,8 @@ const Baz* baz (const Baz_in* baz_in)
         b__4 = o_add_rat_rat(foo->y, b__5);
         break;
       }
+      default:
+        abort();
     }
     b__1 = catala_some(b__4);
   }
@@ -120,7 +125,7 @@ const Baz* baz (const Baz_in* baz_in)
     static const catala_code_position pos[1] =
       {{"tests/backends/simple.catala_en", 12, 10, 12, 11}};
     catala_error(catala_no_value, pos);
-    return NULL;
+    abort();
   }
   c__2->size = 2;
   c__2->elements = catala_malloc(2 * sizeof(void*));
@@ -133,7 +138,7 @@ const Baz* baz (const Baz_in* baz_in)
     static const catala_code_position pos[1] =
       {{"tests/backends/simple.catala_en", 13, 10, 13, 11}};
     catala_error(catala_no_value, pos);
-    return NULL;
+    abort();
   }
   baz__1->b = b;
   baz__1->c = c;