Floating point primitive

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,10 @@ 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 +103,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 +132,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 +157,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 +174,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
@@ -224,17 +239,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,6 +28,7 @@ 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") []

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
@@ -23,6 +23,8 @@ module Lift = struct
     (* Format.printf "lift_type: %S\n" (Clang.Type.show typ); *)
     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

examples/caml_doggo.c

@@ -11,16 +11,18 @@ Doggo* caml_Doggo_of_value(value caml_x) {
   x->many = Int_val(Field(caml_x, 0));
   x->breed = Int_val(Field(caml_x, 1));
   x->wow = Int_val(Field(caml_x, 2));
+  x->weight = Double_val(Field(caml_x, 3));
   return x;
 }
 
 value caml_Doggo_to_value(struct Doggo* x) {
   CAMLparam0();
   CAMLlocal1(caml_x);
-  caml_x = caml_alloc_tuple(3);
+  caml_x = caml_alloc_tuple(4);
   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));
+  Store_field(caml_x, 3, caml_copy_double(x->weight));
   CAMLreturn(caml_x);
 }
 

examples/doggo.c

@@ -11,5 +11,5 @@ static const char* BreedToString[4] = {
 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);
+}

examples/doggo.h

@@ -9,6 +9,7 @@ typedef struct Doggo {
     int many;
     breed breed;
     char wow;
+    float weight;
 } Doggo;
 
 void eleven_out_of_ten_majestic_af(Doggo* pupper);

examples/doggo.ml

@@ -7,6 +7,7 @@ type nonrec breed =
 type nonrec doggo = {
   many: int ;
   breed: breed ;
-  wow: char }
+  wow: char ;
+  weight: float }
 external eleven_out_of_ten_majestic_af :
   pupper:doggo -> unit = "caml_eleven_out_of_ten_majestic_af"

examples/main.ml

@@ -1,5 +1,11 @@
-Doggo.eleven_out_of_ten_majestic_af ~pupper:{
+open Doggo
+
+let pupper = {
   many=2112;
   wow='x';
-  breed=C_Labrador
+  breed=C_Labrador;
+  weight=18.9;
 }
+
+let () =
+  Doggo.eleven_out_of_ten_majestic_af ~pupper