Skip to content

GitLab

Commit 25703954 authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Improve the generation of OCaml binding by making special cases for more builtin types.

parent fd30dbf9
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 637 additions and 524 deletions
lang/runtime/value.ml
View file @ 25703954
This diff is collapsed.
lang/runtime/value.mli
View file @ 25703954
......@@ -113,7 +113,8 @@ val ( |<>| ): t -> t -> bool
val set_cdr : t -> t -> unit
val append_cdr : t -> t -> t
val ocaml2cduce_bool : bool -> t
val cduce2ocaml_bool : t -> bool
val ocaml2cduce_int : int -> t
val cduce2ocaml_int : t -> int
val ocaml2cduce_string : string -> t
......
ocamliface/mlcompat_411_12.ml
View file @ 25703954
(* Compatibilty for OCaml 4.11 & 4.12 *)
open Cduce_core
let longident_parse s = Ocaml_common.Parse.longident (Lexing.from_string s)
let longident_parse s =
let open Ocaml_common in
match String.index_opt s '.' with
| None -> Longident.Lident s
| _ -> Parse.longident (Lexing.from_string s)
module Mlstub =
struct
......
ocamliface/mlstub.real.ml
View file @ 25703954
......@@ -62,15 +62,16 @@ and typ_descr = function
let l = ident_to_string l in
let l = List.map (fun (lab, t) -> (label lab, typ t)) l in
Types.record_fields (false, LabelMap.from_list_disj l)
| Abstract "int" -> Builtin_defs.caml_int
| Abstract "char" -> Builtin_defs.char_latin1
| Abstract "string" -> Builtin_defs.string_latin1
| Builtin ("bool", []) -> Builtin_defs.bool
| Builtin ("int", []) -> Builtin_defs.caml_int
| Builtin ("char", []) -> Builtin_defs.char_latin1
| Builtin ("string", []) -> Builtin_defs.string_latin1
| Abstract s -> Types.abstract (Types.Abstract.atom s)
| Builtin ("list", [ t ]) | Builtin ("array", [ t ]) ->
Types.descr (Sequence.star_node (typ t))
| Builtin ("Stdlib.ref", [ t ]) -> Builtin_defs.ref_type (typ t)
| Builtin ("Big_int.big_int", []) -> Builtin_defs.int
| Builtin ("Cduce_core.Value.t", []) -> Types.any
| Builtin ("Value.t", []) -> Types.any
| Builtin ("Cduce_types.Encodings.Utf8.t", []) -> Builtin_defs.string
| Builtin ("Cduce_types.Atoms.V.t", []) -> Builtin_defs.atom
| Builtin ("unit", []) -> Sequence.nil_type
......@@ -207,12 +208,11 @@ module ML = struct
end
module CD = struct
let atom_ascii lab = ML.sapply "Cduce_core.Value.atom_ascii" [ ML.str_e lab ]
let atom_ascii lab = ML.sapply "Value.atom_ascii" [ ML.str_e lab ]
let label_ascii lab =
ML.sapply "Cduce_core.Value.label_ascii" [ ML.str_e lab ]
let label_ascii lab = ML.sapply "Value.label_ascii" [ ML.str_e lab ]
let pair e1 e2 = ML.sapply "Cduce_core.Value.pair" [ e1; e2 ]
let pair e1 e2 = ML.sapply "Value.pair" [ e1; e2 ]
let rec tuple = function
| [ v ] -> v
......@@ -223,14 +223,14 @@ module CD = struct
| [ v1; v2 ] ->
ML.let_in
(ML.pat_tuple [ ML.pat_var v1; ML.pat_var v2 ])
(ML.sapply "Cduce_core.Value.get_pair" [ ine ])
(ML.sapply "Value.get_pair" [ ine ])
oute
| v :: vl ->
let r = mk_var () in
let oute = matches (ML.var r) oute vl in
ML.let_in
(ML.pat_tuple [ ML.pat_var v; ML.pat_var r ])
(ML.sapply "Cduce_core.Value.get_pair" [ ine ])
(ML.sapply "Value.get_pair" [ ine ])
oute
| [] -> assert false
end
......@@ -243,6 +243,29 @@ let gen_types = ref true
module HashTypes = Hashtbl.Make (Types)
let registered_types = ref []
let nb_registered_types = ref 0
let register_type t =
assert !gen_types;
let _, n =
try List.find (fun (s, i) -> Cduce_types.Types.equiv t s) !registered_types
with Not_found ->
let i = !nb_registered_types in
let kv = (t, i) in
registered_types := kv :: !registered_types;
incr nb_registered_types;
kv
in
ML.(sapply "Array.get" [ var "types"; int n ])
let get_registered_types () =
let a = Array.make !nb_registered_types Types.empty in
List.iter (fun (t, i) -> a.(i) <- t) !registered_types;
a
(*
let registered_types = HashTypes.create 13
let nb_registered_types = ref 0
......@@ -263,6 +286,10 @@ let get_registered_types () =
let a = Array.make !nb_registered_types Types.empty in
HashTypes.iter (fun t i -> a.(i) <- t) registered_types;
a
*)
let is_recursive (t : Mltypes.t) =
match t.def with Abstract _ | Builtin (_, []) -> false | _ -> t.recurs > 0
(* OCaml -> CDuce conversions *)
......@@ -270,17 +297,43 @@ let to_cd_gen = ref []
let to_cd_fun_name t = Printf.sprintf "to_cd_%i" t.uid
let to_cd_fun t =
to_cd_gen := t :: !to_cd_gen;
to_cd_fun_name t
let rec to_cd_fun t =
match t.def with
| Builtin ("bool", []) -> "Value.ocaml2cduce_bool"
| Builtin ("int", []) -> "Value.ocaml2cduce_int"
| Builtin ("char", []) -> "Value.ocaml2cduce_char"
| Builtin ("string", []) -> "Value.ocaml2cduce_string"
| Builtin ("Big_int.big_int", []) -> "Value.ocaml2cduce_bigint"
| Builtin ("Cduce_types.Encodings.Utf8.t", []) ->
"Value.ocaml2cduce_string_utf8"
| Builtin ("Cduce_types.Atoms.V.t", []) -> "Value.ocaml2cduce_atom"
| Link tt when t.recurs <= 0 -> to_cd_fun tt
| Link ({ def = (Link _ | Builtin (_, [])| Abstract _); _} as tt) -> to_cd_fun tt
| _ ->
to_cd_gen := t :: !to_cd_gen;
to_cd_fun_name t
let to_ml_gen = ref []
let to_ml_fun_name t = Printf.sprintf "to_ml_%i" t.uid
let to_ml_fun t =
to_ml_gen := t :: !to_ml_gen;
to_ml_fun_name t
let rec to_ml_fun t =
match t.def with
| Abstract _ -> "Value.get_abstract"
| Builtin ("Big_int.big_int", []) -> "Value.cduce2ocaml_bigint"
| Builtin ("bool", []) -> "Value.cduce2ocaml_bool"
| Builtin ("int", []) -> "Value.cduce2ocaml_int"
| Builtin ("char", []) -> "Value.cduce2ocaml_char"
| Builtin ("string", []) -> "Value.cduce2ocaml_string"
| Builtin ("Cduce_types.Encodings.Utf8.t", []) ->
"Value.cduce2ocaml_string_utf8"
| Builtin ("Cduce_types.Atoms.V.t", []) -> "Value.cduce2ocaml_atom"
| Link tt when t.recurs <= 0 -> to_ml_fun tt
| Link ({ def = (Link _ | Builtin (_, [])| Abstract _); _} as tt) -> to_ml_fun tt
| _ ->
Format.eprintf "Getting %a in to_ml_fun (%b)\n%!" Mltypes.print t (t.recurs > 0);
to_ml_gen := t :: !to_ml_gen;
to_ml_fun_name t
let call_lab f l x =
if l = "" then ML.apply f [ (ML.no_label, x) ]
......@@ -298,9 +351,10 @@ let abstr_lab l x res =
let rec to_cd e t =
(* Format.fprintf Format.err_formatter "to_cd %a [uid=%i; recurs=%i]@."
Mltypes.print t t.uid t.recurs; *)
if t.recurs > 0 then ML.sapply (to_cd_fun t) [ e ] else to_cd_descr e t.def
if t.recurs > 0 then ML.sapply (to_cd_fun t) [ e ] else to_cd_descr e t
and to_cd_descr e = function
and to_cd_descr e t =
match t.def with
| Link t -> to_cd e t
| Arrow (l, t, s) ->
(* let y = <...> in Value.Abstraction ([t,s], fun x -> s(y ~l:(t(x))) *)
......@@ -317,8 +371,7 @@ and to_cd_descr e = function
ML.(some (cons (tuple [ tt; ss ]) nil))
else ML.none
in
ML.constr "Cduce_core.Value.Abstraction"
(Some ML.(tuple [ iface; abs ])))
ML.constr "Value.Abstraction" (Some ML.(tuple [ iface; abs ])))
e
| Tuple tl ->
(* let (x1,...,xn) = ... in Value.Pair (t1(x1), Value.Pair(...,tn(xn))) *)
......@@ -385,22 +438,16 @@ and to_cd_descr e = function
ML.tuple [ CD.label_ascii lab; e ])
l
in
ML.sapply "Cduce_core.Value.record" [ ML.list_list l ])
ML.sapply "Value.record" [ ML.list_list l ])
e
| Abstract "int" -> ML.sapply "Cduce_core.Value.ocaml2cduce_int" [ e ]
| Abstract "char" -> ML.sapply "Cduce_core.Value.ocaml2cduce_char" [ e ]
| Abstract "string" -> ML.sapply "Cduce_core.Value.ocaml2cduce_string" [ e ]
| Abstract s -> ML.sapply "Cduce_core.Value.abstract" [ ML.str_e s; e ]
| Builtin ("list", [ t ]) ->
(* Value.sequence_rev (List.rev_map fun_t <...>) *)
ML.(
sapply "Cduce_core.Value.sequence_rev"
sapply "Value.sequence_rev"
[ sapply "Stdlib.List.rev_map" [ var (to_cd_fun t); e ] ])
| Builtin ("Stdlib.Seq.t", [ t ]) ->
ML.(sapply "Cduce_core.Value.ocaml2cduce_seq" [ var (to_cd_fun t); e ])
| Builtin ("array", [ t ]) ->
ML.(
sapply "Cduce_core.Value.sequence_rev"
sapply "Value.sequence_rev"
[
sapply "Stdlib.List.rev_map"
[ var (to_cd_fun t); sapply "Stdlib.Array.to_list" [ e ] ];
......@@ -436,31 +483,30 @@ and to_cd_descr e = function
let y = mk_var () in
let tr_y = to_ml (var y) t in
let set = fun_ y (setfield e (lid "contents") tr_y) in
ML.sapply "Cduce_core.Value.mk_ext_ref" [ tt; get; set ])
ML.sapply "Value.mk_ext_ref" [ tt; get; set ])
e)
| Builtin ("Big_int.big_int", []) ->
ML.sapply "Cduce_core.Value.ocaml2cduce_bigint" [ e ]
| Builtin ("Cduce_core.Value.t", []) -> e
| Builtin ("Cduce_types.Encodings.Utf8.t", []) ->
ML.sapply "Cduce_core.Value.ocaml2cduce_string_utf8" [ e ]
| Builtin ("Cduce_types.Atoms.V.t", []) ->
ML.sapply "Cduce_core.Value.ocaml2cduce_atom" [ e ]
| Builtin ("unit", []) -> ML.(let_in (pany ()) e (var "Cduce_core.Value.nil"))
| Var _ -> e
| Builtin ("unit", []) -> ML.(let_in (pany ()) e (var "Value.nil"))
| Builtin ("Stdlib.Seq.t", [ t ]) ->
ML.(sapply "Value.ocaml2cduce_seq" [ var (to_cd_fun t); e ])
| Builtin ("option", [ t ]) ->
ML.sapply "Cduce_core.Value.ocaml2cduce_option"
[ ML.var (to_cd_fun t); e ]
ML.sapply "Value.ocaml2cduce_option" [ ML.var (to_cd_fun t); e ]
| Builtin ("Value.t", []) -> e
| Abstract s -> ML.sapply "Value.abstract" [ ML.str_e s; e ]
| Var _ -> e
(* the remaining cases are handled by to_cd_fun *)
| Builtin (_, []) -> ML.sapply (to_cd_fun t) [ e ]
| _ -> assert false
and tuple_to_cd tl vars = List.map2 (fun t id -> to_cd (ML.var id) t) tl vars
(* CDuce -> OCaml conversions *)
and to_ml e (t : Mltypes.t) =
(* Format.fprintf Format.err_formatter "to_ml %a@."
Mltypes.print t; *)
if t.recurs > 0 then ML.sapply (to_ml_fun t) [ e ] else to_ml_descr e t.def
(*Format.fprintf Format.err_formatter "to_ml %a@."
Mltypes.print t;*)
if is_recursive t then ML.sapply (to_ml_fun t) [ e ] else to_ml_descr e t
and to_ml_descr e = function
and to_ml_descr e t =
match t.def with
| Link t -> to_ml e t
| Arrow (l, t, s) ->
(* let y = <...> in fun ~l:x -> s(Eval.eval_apply y (t(x))) *)
......@@ -468,9 +514,7 @@ and to_ml_descr e = function
(fun y ->
let x = mk_var () in
let arg = to_cd (ML.var x) t in
let res =
to_ml (ML.sapply "Cduce_core.Eval.eval_apply" [ y; arg ]) s
in
let res = to_ml (ML.sapply "Eval.eval_apply" [ y; arg ]) s in
abstr_lab l x res)
e
| Tuple tl ->
......@@ -505,7 +549,7 @@ and to_ml_descr e = function
l
in
let cases = cases @ [ ML.(case (pany ()) assert_false) ] in
ML.pmatch (ML.sapply "Cduce_core.Value.get_variant" [ e ]) cases
ML.pmatch (ML.sapply "Value.get_variant" [ e ]) cases
| Variant (_, l, false) -> failwith "Private Sum type"
| Variant (p, l, true) ->
let cases =
......@@ -553,7 +597,7 @@ and to_ml_descr e = function
l
in
let cases = cases @ [ ML.(case (pany ()) assert_false) ] in
ML.pmatch (ML.sapply "Cduce_core.Value.get_variant" [ e ]) cases
ML.pmatch (ML.sapply "Value.get_variant" [ e ]) cases
| Record (_, l, false) -> failwith "Private Record type"
| Record (p, l, true) ->
(* (\* let x = <...> in
......@@ -583,49 +627,30 @@ and to_ml_descr e = function
in
record l)
e)
| Abstract "int" -> ML.sapply "Cduce_core.Value.cduce2ocaml_int" [ e ]
| Abstract "char" -> ML.sapply "Cduce_core.Value.cduce2ocaml_char" [ e ]
| Abstract "string" -> ML.sapply "Cduce_core.Value.cduce2ocaml_string" [ e ]
| Abstract _ -> ML.sapply "Cduce_core.Value.get_abstract" [ e ]
| Builtin ("list", [ t ]) ->
(* List.rev_map fun_t (Value.get_sequence_rev <...> *)
ML.sapply "Stdlib.List.rev_map"
[
ML.var (to_ml_fun t);
ML.sapply "Cduce_core.Value.get_sequence_rev" [ e ];
]
[ ML.var (to_ml_fun t); ML.sapply "Value.get_sequence_rev" [ e ] ]
| Builtin ("array", [ t ]) ->
ML.sapply "Stdlib.Array.of_list"
[
ML.sapply "Stdlib.List.rev_map"
[
ML.var (to_ml_fun t);
ML.sapply "Cduce_core.Value.get_sequence_rev" [ e ];
];
[ ML.var (to_ml_fun t); ML.sapply "Value.get_sequence_rev" [ e ] ];
]
| Builtin ("Stdlib.ref", [ t ]) ->
let f =
ML.sapply "Cduce_core.Value.get_field" [ e; CD.label_ascii "get" ]
in
let e =
ML.sapply "Cduce_core.Eval.eval_apply"
[ f; ML.var "Cduce_core.Value.nil" ]
in
let f = ML.sapply "Value.get_field" [ e; CD.label_ascii "get" ] in
let e = ML.sapply "Eval.eval_apply" [ f; ML.var "Value.nil" ] in
ML.sapply "Stdlib.ref" [ to_ml e t ]
| Builtin ("Big_int.big_int", []) ->
ML.sapply "Cduce_core.Value.cduce2ocaml_bigint" [ e ]
| Builtin ("Cduce_core.Value.t", []) -> e
| Builtin ("Cduce_types.Encodings.Utf8.t", []) ->
ML.sapply "Cduce_core.Value.cduce2ocaml_string_utf8" [ e ]
| Builtin ("Cduce_types.Atoms.V.t", []) ->
ML.sapply "Cduce_core.Value.cduce2ocaml_atom" [ e ]
| Builtin ("Value.t", []) -> e
| Builtin ("unit", []) -> ML.(let_in (pany ()) e unit)
| Builtin ("option", [ t ]) ->
ML.sapply "Cduce_core.Value.cduce2ocaml_option"
[ ML.var (to_ml_fun t); e ]
ML.sapply "Value.cduce2ocaml_option" [ ML.var (to_ml_fun t); e ]
| Builtin ("Stdlib.Seq.t", [ t ]) ->
ML.sapply "Cduce_core.Value.cduce2ocaml_seq" [ ML.var (to_ml_fun t); e ]
ML.sapply "Value.cduce2ocaml_seq" [ ML.var (to_ml_fun t); e ]
| Var _ -> e
(* Other cases handled by to_ml_fun *)
| Abstract _s -> ML.sapply (to_ml_fun t) [ e ]
| Builtin (_, []) -> ML.sapply (to_ml_fun t) [ e ]
| _ -> assert false
and tuple_to_ml tl vars =
......@@ -642,7 +667,7 @@ let global_transl () =
if not (IntHash.mem don hd.uid) then (
IntHash.add don hd.uid ();
let p = ML.pat_var (fun_name hd) in
let e = ML.(fun_ "x" (to_descr (var "x") hd.def)) in
let e = ML.(fun_ "x" (to_descr (var "x") hd)) in
defs := ML.bind p e :: !defs);
loop ()
and loop () =
......@@ -741,7 +766,7 @@ let stub binary name ty_env c_env exts values mk prolog =
pat_var "slots";
pat_var "run";
])
(sapply "Cduce_core.Librarian.ocaml_stub" [ str raw ]);
(sapply "Librarian.ocaml_stub" [ str raw ]);
];
Str.value rec_ g;
Str.eval (sapply "set_externals" [ Exp.array exts ]);
......@@ -879,7 +904,7 @@ let make_wrapper binary fn =
[
Str.eval
(Exp.setfield
(Exp.ident (ML.lid "Cduce_core.Cduce_loc.obj_path"))
(Exp.ident (ML.lid "Cduce_loc.obj_path"))
(ML.lid "contents")
(ML.list_list
(List.map (fun p -> ML.str p) !Cduce_core.Cduce_loc.obj_path)));
......
ocamliface/mltypes.real.ml
View file @ 25703954
......@@ -141,6 +141,10 @@ let builtins =
(fun m x -> StringSet.add x m)
StringSet.empty
[
"bool";
"int";
"char";
"string";
"list";
"Stdlib.ref";
"Stdlib.Seq.t";
......
tests/libtest/dune
View file @ 25703954
(library
(name libtest)
(wrapped false)
(libraries )
)
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment