diff --git a/bindgen/c.ml b/bindgen/c.ml index 20b4b41..512b5e4 100644 --- a/bindgen/c.ml +++ b/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,6 +65,7 @@ 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 } @@ -73,6 +73,7 @@ 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 ""; C_include ""; ] - @ - (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) diff --git a/bindgen/caml.ml b/bindgen/caml.ml index 50353aa..b1821b5 100644 --- a/bindgen/caml.ml +++ b/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 | [] -> diff --git a/bindgen/codegen.ml b/bindgen/codegen.ml index c4935d1..a46b595 100644 --- a/bindgen/codegen.ml +++ b/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 +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)); +} |} diff --git a/bindgen/dunefile.ml b/bindgen/dunefile.ml index 4ea3f3e..3caedd7 100644 --- a/bindgen/dunefile.ml +++ b/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"; } diff --git a/bindgen/ir.ml b/bindgen/ir.ml index 13b4b8e..e3f4183 100644 --- a/bindgen/ir.ml +++ b/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)" diff --git a/bindgen/runtime.ml b/bindgen/runtime.ml new file mode 100644 index 0000000..75acbcf --- /dev/null +++ b/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 } diff --git a/examples/caml_doggo.c b/examples/caml_doggo.c index 35536cb..cb7e28b 100644 --- a/examples/caml_doggo.c +++ b/examples/caml_doggo.c @@ -1,4 +1,5 @@ /* automatically generated by ocaml-bindgen 0.0.1 */ + #include "doggo.h" #include #include @@ -6,35 +7,32 @@ #include #include #include -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 +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)); +} \ No newline at end of file diff --git a/examples/doggo.c b/examples/doggo.c index bbf5c9d..9f1fe0a 100644 --- a/examples/doggo.c +++ b/examples/doggo.c @@ -1,18 +1,30 @@ #include #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"); -} \ No newline at end of file +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); +// } diff --git a/examples/doggo.h b/examples/doggo.h index cc65fe9..c241b6d 100644 --- a/examples/doggo.h +++ b/examples/doggo.h @@ -1,16 +1,19 @@ -typedef enum breed { - Labrador, - _GoldenRetriever, - pug, - _poodle -} breed; +// typedef enum breed { +// Labrador, +// _GoldenRetriever, +// pug, +// _poodle +// } breed; -typedef struct Doggo { - int many; - breed breed; - char wow; -} Doggo; +// typedef struct Doggo { +// int many; +// // breed breed; +// char wow; +// float weight; +// } Doggo; -void eleven_out_of_ten_majestic_af(Doggo* pupper); +// void eleven_out_of_ten_majestic_af(Doggo* pupper); -void no_input_no_output(void); \ No newline at end of file +void print_age(int* age); +// void print_name(char* name); +// void print_doggo(Doggo *dog); \ No newline at end of file diff --git a/examples/doggo.ml b/examples/doggo.ml deleted file mode 100644 index ca1434a..0000000 --- a/examples/doggo.ml +++ /dev/null @@ -1,13 +0,0 @@ -(* automatically generated by ocaml-bindgen 0.0.1 *) -type nonrec breed = - | C_Labrador - | C__GoldenRetriever - | C_pug - | C__poodle -type nonrec doggo = { - many: int ; - breed: breed ; - wow: char } -external eleven_out_of_ten_majestic_af : - pupper:doggo -> unit = "caml_eleven_out_of_ten_majestic_af" -external no_input_no_output : unit -> unit = "caml_no_input_no_output" diff --git a/examples/doggo_sys.ml b/examples/doggo_sys.ml new file mode 100644 index 0000000..7882677 --- /dev/null +++ b/examples/doggo_sys.ml @@ -0,0 +1,23 @@ +(* automatically generated by ocaml-bindgen 0.0.1 *) +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 } + +external print_age : age:int cptr -> unit = "caml_print_age" diff --git a/examples/dune b/examples/dune index e31905b..aedeb7c 100644 --- a/examples/dune +++ b/examples/dune @@ -1,5 +1,6 @@ (executable - (name main) + (name main) + (libraries bindgen) (foreign_stubs (language c) (names doggo caml_doggo) @@ -8,13 +9,9 @@ (rule (alias all) - (targets - doggo.ml - caml_doggo.c - ) + (targets doggo_sys.ml caml_doggo.c) (deps doggo.h) (action - (run - %{bin:ocaml-bindgen} doggo.h doggo)) + (run %{bin:ocaml-bindgen} doggo.h doggo)) (mode (promote (until-clean)))) diff --git a/examples/main.ml b/examples/main.ml index 120443f..53cb9e6 100644 --- a/examples/main.ml +++ b/examples/main.ml @@ -1,5 +1,10 @@ -Doggo.eleven_out_of_ten_majestic_af ~pupper:{ - many=2112; - wow='x'; - breed=C_Labrador -} +(* open Doggo *) + +module Doggo = struct + include Doggo_sys + (** Here is where we would write our wrappers around the raw bindings *) + + let wrapper_print_age (age : int) = print_age ~age:(create_ptr age) +end + +let () = Doggo.wrapper_print_age 25