RFC: Brainstorming pointer parameters

bindgen/c.ml

@@ -1,7 +1,7 @@
 let caml_ = "caml_"
 
 type c_type = Prim of string | Struct of string | Ptr of c_type | Void
-type c_prim = Int of int | Str of string
+type c_prim = Int of int | Float of float | Str of string
 
 type t =
   | C_function of {
@@ -23,7 +23,6 @@ type t =
 
 type program = t list
 
-
 let pp_list sep pp_el fmt t =
   Format.pp_print_list
     ~pp_sep:(fun fmt () -> Format.fprintf fmt "%s" sep)
@@ -66,13 +65,15 @@ and pp_type fmt (ctype : c_type) =
 and pp_prim fmt (prim : c_prim) =
   match prim with
   | Int d -> Format.fprintf fmt "%d" d
+  | Float f -> Format.fprintf fmt "%f" f
   | Str s -> Format.fprintf fmt "%s" s
 
 let decl dcl_type dcl_name dcl_value = C_decl { dcl_name; dcl_type; dcl_value }
 let call cc_name cc_args = C_call { cc_name; cc_args }
 let var x = C_variable x
 let assign asg_var asg_value = C_assign { asg_var; asg_value }
 let int x = C_prim (Int x)
+let float f = C_prim (Float f)
 let string x = C_prim (Str x)
 let ptr_field pfa_name pfa_field = C_ptr_field_access { pfa_name; pfa_field }
 let typ t = C_type t
@@ -90,7 +91,9 @@ let caml_alloc_tuple fields =
 
 let store_field var idx value = call "Store_field" [ var; int idx; value ]
 let val_int var name = call "Val_int" [ ptr_field var name ]
-let int_val var idx = call "Int_val" [ call "Field" [ var; int idx] ]
+let int_val var idx = call "Int_val" [ call "Field" [ var; int idx ] ]
+let val_float var name = call "caml_copy_double" [ ptr_field var name ]
+let float_val var idx = call "Double_val" [ call "Field" [ var; int idx ] ]
 
 (* from_ir *)
 let rec ctype_of_ir (ir_type : Ir.ir_type) =
@@ -99,6 +102,7 @@ let rec ctype_of_ir (ir_type : Ir.ir_type) =
   | Ir.Record { rec_name; _ } -> Prim rec_name
   | Ir.Enum { enum_name; _ } -> Prim enum_name
   | Ir.Prim Ir.Int -> Prim "int"
+  | Ir.Prim Ir.Float -> Prim "float"
   | Ir.Prim Ir.Bool -> Prim "bool"
   | Ir.Prim Ir.Char -> Prim "char"
   | Ir.Prim Ir.Void -> Void
@@ -127,9 +131,13 @@ module Shims = struct
           ]
           @ Ir.(
               List.mapi
-                (fun idx field ->
-                  store_field (var "caml_x") idx
-                    (val_int (var "x") field.fld_name))
+                (fun idx fld ->
+                  let fld_caml_value =
+                    match fld.fld_type with
+                    | Prim Float -> val_float (var "x") fld.fld_name
+                    | _ -> val_int (var "x") fld.fld_name
+                  in
+                  store_field (var "caml_x") idx fld_caml_value)
                 fields)
           @ [ caml_return (var "caml_x") ];
       }
@@ -148,9 +156,12 @@ module Shims = struct
           @ Ir.(
               List.mapi
                 (fun idx fld ->
-                  assign
-                    (ptr_field (var "x") fld.fld_name)
-                    (int_val (var "caml_x") idx))
+                  let field_c_value =
+                    match fld.fld_type with
+                    | Prim Float -> float_val (var "caml_x") idx
+                    | _ -> int_val (var "caml_x") idx
+                  in
+                  assign (ptr_field (var "x") fld.fld_name) field_c_value)
                 fields)
           @ [ return (var "x") ];
       }
@@ -162,7 +173,10 @@ module Shims = struct
 
         let fn_body =
           let declare_params =
-            [ caml_params (List.map (fun (name, _type) -> var (caml_^name)) fn_params ) ]
+            [
+              caml_params
+                (List.map (fun (name, _type) -> var (caml_ ^ name)) fn_params);
+            ]
           in
           let maybe_declare_result =
             match fn_ret with
@@ -174,12 +188,20 @@ module Shims = struct
             List.map
               (fun (name, param_type) ->
                 let c_type = ctype_of_ir param_type in
-                let c_type_name = ctype_name c_type in
-                decl c_type name
-                  (Some
-                     (call
-                        (caml_ ^ c_type_name ^ "_of_value")
-                        [ var (caml_ ^ name) ])))
+                match c_type with
+                | Ptr _t ->
+                    let _c_type_name = ctype_name c_type in
+                    decl c_type name
+                      (Some
+                         (call "Nativeint_val"
+                            [ call "Field" [ var (caml_ ^ name); int 1 ] ]))
+                | _ ->
+                    let c_type_name = ctype_name c_type in
+                    decl c_type name
+                      (Some
+                         (call
+                            (caml_ ^ c_type_name ^ "_of_value")
+                            [ var (caml_ ^ name) ])))
               fn_params
           in
 
@@ -224,17 +246,16 @@ let from_ir (ir : Ir.t) : program =
     C_include "<caml/mlvalues.h>";
     C_include "<caml/unixsupport.h>";
   ]
-  @
-  (List.filter_map
-    (fun node ->
-      match node with
-      | Ir.Ir_fun_decl fun_decl -> Some [ Shims.wrap_fun fun_decl ]
-      | Ir.Ir_type (Record { rec_name; rec_fields }) ->
-          Some
-            [
-              Shims.of_value rec_name rec_fields;
-              Shims.to_value rec_name rec_fields;
-            ]
-      | _ -> None)
-    ir.items
-  |> List.flatten)
+  @ (List.filter_map
+       (fun node ->
+         match node with
+         | Ir.Ir_fun_decl fun_decl -> Some [ Shims.wrap_fun fun_decl ]
+         | Ir.Ir_type (Record { rec_name; rec_fields }) ->
+             Some
+               [
+                 Shims.of_value rec_name rec_fields;
+                 Shims.to_value rec_name rec_fields;
+               ]
+         | _ -> None)
+       ir.items
+    |> List.flatten)

bindgen/caml.ml

@@ -28,10 +28,11 @@ let rec core_type_from_ir typ =
   | Ir.Enum { enum_name; _ } -> Typ.constr (lid enum_name) []
   | Ir.Record { rec_name; _ } -> Typ.constr (lid rec_name) []
   | Ir.Prim Int -> Typ.constr (lid "int") []
+  | Ir.Prim Float -> Typ.constr (lid "float") []
   | Ir.Prim Bool -> Typ.constr (lid "bool") []
   | Ir.Prim Char -> Typ.constr (lid "char") []
   | Ir.Prim Void -> Typ.constr (lid "unit") []
-  | Ir.Ptr t -> core_type_from_ir t
+  | Ir.Ptr t -> Typ.constr (lid "cptr") [ core_type_from_ir t ]
   | Ir.Func { fn_ret; fn_params } -> (
       match fn_params with
       | [] ->

bindgen/codegen.ml

@@ -5,6 +5,8 @@ let with_file file fn =
   close_out oc;
   ()
 
+let read_file file = In_channel.with_open_bin file In_channel.input_all
+
 let write_dune_file (dune : Dunefile.t) =
   with_file "dune" @@ fun fmt ->
   Format.fprintf fmt
@@ -22,11 +24,35 @@ let write_dune_file (dune : Dunefile.t) =
   Format.fprintf fmt "\n%!"
 
 let write_caml_files caml (dune : Dunefile.t) =
+  let runtime_ocaml = read_file "../bindgen/runtime.ml" in
   with_file dune.caml_file_name @@ fun fmt ->
   Format.fprintf fmt "(* automatically generated by ocaml-bindgen 0.0.1 *)\n";
+  Format.fprintf fmt "%s\n" runtime_ocaml;
   Format.fprintf fmt "%s\n%!" (Format.asprintf "%a" Pprintast.structure caml)
 
 let write_c_files (c : C.program) (dune : Dunefile.t) =
   with_file dune.c_file_name @@ fun fmt ->
   Format.fprintf fmt "/* automatically generated by ocaml-bindgen 0.0.1 */\n";
-  Format.fprintf fmt "%s\n%!" (Format.asprintf "%a" C.pp c)
+  Format.fprintf fmt "\n%s\n%!" (Format.asprintf "%a" C.pp c);
+  Format.fprintf fmt
+    {|#include <stdlib.h>
+value bindgen_alloc(value caml_size) {
+    CAMLparam1(caml_size);
+
+    // Convert OCaml integer to C size
+    size_t size = Int_val(caml_size);
+    printf("Allocated size %%ld \n", size);
+
+    void* ptr = malloc(sizeof(size));
+    if (ptr == NULL) {
+        // TODO: handle allocation failure
+        CAMLreturn(Val_unit);
+    }
+
+    // Wrap the pointer as an OCaml value
+    CAMLreturn(caml_copy_nativeint(ptr));
+}
+
+void bindgen_free(value caml_addr) {
+    free(Nativeint_val(caml_addr));
+} |}

bindgen/dunefile.ml

@@ -3,6 +3,6 @@ type t = { lib_name : string; caml_file_name : string; c_file_name : string }
 let from_ir (ir : Ir.t) : t =
   {
     lib_name = ir.lib_name;
-    caml_file_name = ir.lib_name ^ ".ml";
+    caml_file_name = ir.lib_name ^ "_sys" ^ ".ml";
     c_file_name = "caml_" ^ ir.lib_name ^ ".c";
   }

bindgen/ir.ml

@@ -1,4 +1,4 @@
-type ir_prim_type = Int | Bool | Char | Void
+type ir_prim_type = Int | Float | Bool | Char | Void
 
 type ir_type =
   | Abstract of string
@@ -20,9 +20,11 @@ module Lift = struct
     match name with Clang.Ast.IdentifierName x -> x | _ -> assert false
 
   let rec lift_type (typ : Clang.Type.t) =
-    (* Format.printf "lift_type: %S\n" (Clang.Type.show typ); *)
+    (* Format.printf "lift_type: %S\n" (Clang.Type.show typ); flush stdout; *)
     match typ.desc with
     | Clang.Ast.BuiltinType Int -> Prim Int
+    | Clang.Ast.BuiltinType Float -> Prim Float
+    | Clang.Ast.BuiltinType Double -> Prim Float
     | Clang.Ast.BuiltinType Bool -> Prim Bool
     | Clang.Ast.BuiltinType Char_S -> Prim Char
     | Clang.Ast.BuiltinType Void -> Prim Void
@@ -105,3 +107,9 @@ module Lift = struct
 end
 
 let lift = Lift.lift
+
+let string_of_prim prim =
+  match prim with
+  | Int -> "Int"
+  | Char -> "Char"
+  | Float | Bool | Void -> "Other (TODO)"

bindgen/runtime.ml

@@ -0,0 +1,20 @@
+type lifetime =
+  | Function
+      (** The value can live for the lifetime of the function call, which upon return will signal that the 
+               value can be dropped (finalizer?) *)
+  | Ocaml  (** The value is managed by the OCaml runtime *)
+  | C
+      (** The value is allocated and passed to C which is then in charge of cleaning it up *)
+
+type 'a cptr = { lifetime : lifetime; addr : nativeint }
+
+external bindgen_alloc : size:int -> nativeint = "bindgen_alloc"
+external bindgen_free : nativeint -> unit = "bindgen_free"
+
+let sizeof _ = 4 (* TODO: how to handle different types? *)
+
+let create_ptr (value : 'a) : 'a cptr =
+  let addr = bindgen_alloc ~size:(sizeof value) in
+  print_endline ("Addr: " ^ Nativeint.to_string addr);
+  Gc.finalise bindgen_free addr;
+  { lifetime = Ocaml; addr }

examples/caml_doggo.c

@@ -1,40 +1,38 @@
 /* automatically generated by ocaml-bindgen 0.0.1 */
+
 #include "doggo.h"
 #include <caml/alloc.h>
 #include <caml/callback.h>
 #include <caml/fail.h>
 #include <caml/memory.h>
 #include <caml/mlvalues.h>
 #include <caml/unixsupport.h>
-Doggo* caml_Doggo_of_value(value caml_x) {
-  Doggo* x = malloc(sizeof(struct Doggo));
-  x->many = Int_val(Field(caml_x, 0));
-  x->breed = Int_val(Field(caml_x, 1));
-  x->wow = Int_val(Field(caml_x, 2));
-  return x;
+void caml_print_age(value caml_age) {
+  CAMLparam1(caml_age);
+  int* age = Nativeint_val(Field(caml_age, 1));
+  print_age(age);
+  CAMLreturn0;
 }
 
-value caml_Doggo_to_value(struct Doggo* x) {
-  CAMLparam0();
-  CAMLlocal1(caml_x);
-  caml_x = caml_alloc_tuple(3);
-  Store_field(caml_x, 0, Val_int(x->many));
-  Store_field(caml_x, 1, Val_int(x->breed));
-  Store_field(caml_x, 2, Val_int(x->wow));
-  CAMLreturn(caml_x);
-}
 
-void caml_eleven_out_of_ten_majestic_af(value caml_pupper) {
-  CAMLparam1(caml_pupper);
-  Doggo* pupper = caml_Doggo_of_value(caml_pupper);
-  eleven_out_of_ten_majestic_af(pupper);
-  CAMLreturn0;
-}
+#include <stdlib.h>
+value bindgen_alloc(value caml_size) {
+    CAMLparam1(caml_size);
 
-void caml_no_input_no_output() {
-  CAMLparam0();
-  no_input_no_output();
-  CAMLreturn0;
-}
+    // Convert OCaml integer to C size
+    size_t size = Int_val(caml_size);
+    printf("Allocated size %ld \n", size);
 
+    void* ptr = malloc(sizeof(size));
+    if (ptr == NULL) {
+        // TODO: handle allocation failure
+        CAMLreturn(Val_unit);
+    }
+
+    // Wrap the pointer as an OCaml value
+    CAMLreturn(caml_copy_nativeint(ptr));
+}
 
+void bindgen_free(value caml_addr) {
+    free(Nativeint_val(caml_addr));
+} 

examples/doggo.c

@@ -1,18 +1,30 @@
 #include <stdio.h>
 #include "doggo.h"
 
-static const char* BreedToString[4] = {
-  "Labrador",
-  "Golden Retriever",
-  "Pug",
-  "Poodle"
-};
+// static const char* BreedToString[4] = {
+//   "Labrador",
+//   "Golden Retriever",
+//   "Pug",
+//   "Poodle"
+// };
 
-void eleven_out_of_ten_majestic_af(Doggo* pupper) {
-  printf("doggo says %d\n", pupper->many);
-  printf("doggo is a %s\n", BreedToString[pupper->breed]);
-}
+// void eleven_out_of_ten_majestic_af(Doggo* pupper) {
+//   printf("doggo says %d\n", pupper->many);
+//   printf("doggo is a %s\n", BreedToString[pupper->breed]);
+//   printf("doggo weighs %.1fkg\n", pupper->weight);
+// }
+
+// void no_input_no_output(void) {
+//   printf("We are doing nothing (of importance)\n");
+// }
 
-void no_input_no_output(void) {
-  printf("We are doing nothing (of importance)\n");
-}
+void print_age(int* age) {
+  printf("Age: %d\n", *age);
+}
+// void print_name(char* name) {
+//   printf("Name: %s\n", name);
+// }
+// void print_doggo(Doggo *dog) {
+//   printf("wow: %c\n", dog->wow);
+//   print_age(&dog->many);
+// }