This is an automated email from the git hooks/post-receive script.
glondu pushed a commit to branch master
in repository atdgen.
commit f74d05850780d750110bb44099b6151f62d16f47
Author: Stephane Glondu <st...@glondu.net>
Date: Thu Aug 4 11:14:57 2016 +0200
Imported Upstream version 1.9.1
---
src/Makefile | 2 +-
src/ag_main.ml | 8 +--
src/ag_ob_emit.ml | 73 ++++++++++++++++-----------
src/ag_oj_emit.ml | 17 +++++--
src/ag_ov_emit.ml | 1 +
src/ag_ox_emit.mli | 32 ++++++++++++
test/test_atdgen_main.ml | 127 ++++++++++++++++++++++++++++++++++++++++++++++-
7 files changed, 223 insertions(+), 37 deletions(-)
diff --git a/src/Makefile b/src/Makefile
index c25441a..328539e 100644
--- a/src/Makefile
+++ b/src/Makefile
@@ -1,4 +1,4 @@
-VERSION = 1.9.0
+VERSION = 1.9.1
ifeq "$(shell ocamlc -config |grep os_type)" "os_type: Win32"
EXE=.exe
else
diff --git a/src/ag_main.ml b/src/ag_main.ml
index 3a87e44..5455c92 100644
--- a/src/ag_main.ml
+++ b/src/ag_main.ml
@@ -54,8 +54,8 @@ let parse_ocaml_version () =
else
None
-let get_default_name_overlap () =
- match parse_ocaml_version () with
+let get_default_name_overlap ocaml_version =
+ match ocaml_version with
| Some (major, minor) when major < 4 -> false
| Some (4, 0) -> false
| _ -> true
@@ -77,7 +77,8 @@ let main () =
let unknown_field_handler = ref None in
let constr_mismatch_handler = ref None in
let type_aliases = ref None in
- let name_overlap = ref (get_default_name_overlap ()) in
+ let ocaml_version = parse_ocaml_version () in
+ let name_overlap = ref (get_default_name_overlap ocaml_version) in
let set_opens s =
let l = Str.split (Str.regexp " *, *\\| +") s in
opens := List.rev_append l !opens
@@ -435,6 +436,7 @@ Recommended usage: %s (-t|-b|-j|-v|-dep|-list) example.atd"
Sys.argv.(0) in
~pos_lnum: !pos_lnum
~type_aliases
~force_defaults
+ ~ocaml_version
~name_overlap: !name_overlap
atd_file ocaml_prefix
diff --git a/src/ag_ob_emit.ml b/src/ag_ob_emit.ml
index 71a11f0..ead7476 100644
--- a/src/ag_ob_emit.ml
+++ b/src/ag_ob_emit.ml
@@ -730,7 +730,7 @@ and make_table_writer deref tagged list_kind x =
main
-let study_record deref fields =
+let study_record ~ocaml_version deref fields =
let field_assignments =
List.fold_right (
fun (x, name, default, opt, unwrap) field_assignments ->
@@ -738,7 +738,11 @@ let study_record deref fields =
match default with
None ->
assert (not opt);
- "Obj.magic 0.0"
+ begin match ocaml_version with
+ | Some (maj, min) when (maj > 4 || maj = 4 && min >= 3) ->
+ "Obj.magic (Sys.opaque_identity 0.0)"
+ | _ -> "Obj.magic 0.0"
+ end
| Some s ->
s
in
@@ -890,7 +894,7 @@ let wrap_bodies ~tagged l =
let rec make_reader
- deref ~tagged ?type_annot (x : ob_mapping)
+ deref ~tagged ~ocaml_version ?type_annot (x : ob_mapping)
: Ag_indent.t list =
match x with
`Unit _
@@ -918,7 +922,8 @@ let rec make_reader
Array.to_list (
Array.map
(fun x ->
- `Inline (make_variant_reader deref type_annot tick x)
+ `Inline (make_variant_reader ~ocaml_version
+ deref type_annot tick x)
)
a
)
@@ -937,11 +942,11 @@ let rec make_reader
| `Object ->
error loc "Sorry, OCaml objects are not supported"
);
- let body = make_record_reader deref ~tagged type_annot a o in
+ let body = make_record_reader deref ~ocaml_version ~tagged type_annot
a o in
wrap_body ~tagged Bi_io.record_tag body
| `Tuple (loc, a, `Tuple, `Tuple) ->
- let body = make_tuple_reader deref ~tagged a in
+ let body = make_tuple_reader deref ~ocaml_version ~tagged a in
wrap_body ~tagged Bi_io.tuple_tag body
| `List (loc, x, `List o, `List b) ->
@@ -953,7 +958,7 @@ let rec make_reader
in
[
`Line (f ^ " (");
- `Block (make_reader deref ~tagged:false x);
+ `Block (make_reader deref ~ocaml_version ~tagged:false x);
`Line ")";
]
| `Array, `Array ->
@@ -963,12 +968,13 @@ let rec make_reader
in
[
`Line (f ^ " (");
- `Block (make_reader deref ~tagged:false x);
+ `Block (make_reader deref ~ocaml_version ~tagged:false x);
`Line ")";
]
| list_kind, `Table ->
(* Support table format and regular array format *)
- let body1 = make_table_reader deref loc list_kind x in
+ let body1 =
+ make_table_reader ~ocaml_version deref loc list_kind x in
let body2 =
let f =
match list_kind with
@@ -977,7 +983,7 @@ let rec make_reader
in
[
`Line (f ^ " (");
- `Block (make_reader deref ~tagged:false x);
+ `Block (make_reader deref ~tagged:false ~ocaml_version x);
`Line ") ib";
]
in
@@ -996,7 +1002,7 @@ let rec make_reader
`Line "Some (";
`Block [
`Line "(";
- `Block (make_reader deref ~tagged:true x);
+ `Block (make_reader deref ~tagged:true ~ocaml_version x);
`Line ")";
`Block [ `Line "ib"];
];
@@ -1009,7 +1015,7 @@ let rec make_reader
wrap_body ~tagged Bi_io.num_variant_tag body
| `Wrap (loc, x, `Wrap o, `Wrap) ->
- let simple_reader = make_reader deref ~tagged x in
+ let simple_reader = make_reader deref ~tagged ~ocaml_version x in
(match o with
None -> simple_reader
| Some { Ag_ocaml.ocaml_wrap } ->
@@ -1035,7 +1041,7 @@ let rec make_reader
| _ -> assert false
-and make_variant_reader deref type_annot tick x : Ag_indent.t list =
+and make_variant_reader ~ocaml_version deref type_annot tick x : Ag_indent.t
list =
let o =
match x.var_arepr, x.var_brepr with
`Variant o, `Variant -> o
@@ -1054,7 +1060,7 @@ and make_variant_reader deref type_annot tick x :
Ag_indent.t list =
`Block [
`Block [
`Line "(";
- `Block (make_reader deref ~tagged:true v);
+ `Block (make_reader deref ~tagged:true ~ocaml_version v);
`Line ") ib";
];
`Line (sprintf ")%s)" (Ag_ox_emit.insert_annot type_annot));
@@ -1062,11 +1068,11 @@ and make_variant_reader deref type_annot tick x :
Ag_indent.t list =
]
and make_record_reader
- deref ~tagged type_annot
+ deref ~ocaml_version ~tagged type_annot
a record_kind =
let fields = get_fields deref a in
let init_fields, init_bits, set_bit, check_bits, create_record =
- study_record deref fields
+ study_record ~ocaml_version deref fields
in
let body =
@@ -1090,7 +1096,7 @@ and make_record_reader
let read_value =
[
`Line "(";
- `Block (make_reader deref ~tagged:true f_value);
+ `Block (make_reader deref ~tagged:true ~ocaml_version f_value);
`Line ") ib"
]
in
@@ -1128,7 +1134,7 @@ and make_record_reader
]
-and make_tuple_reader deref ~tagged a =
+and make_tuple_reader deref ~tagged ~ocaml_version a =
let cells =
Array.map (
fun x ->
@@ -1157,7 +1163,9 @@ and make_tuple_reader deref ~tagged a =
Array.to_list (
Array.mapi (
fun i (x, default) ->
- let read_value = make_reader deref ~tagged:true x.cel_value in
+ let read_value =
+ make_reader deref ~ocaml_version ~tagged:true
+ x.cel_value in
let get_value =
if i < min_length then
[
@@ -1212,7 +1220,7 @@ and make_tuple_reader deref ~tagged a =
]
-and make_table_reader deref loc list_kind x =
+and make_table_reader deref ~ocaml_version loc list_kind x =
let empty_list, to_list =
match list_kind with
`List -> "[ ]", (fun s -> "Array.to_list " ^ s)
@@ -1231,7 +1239,7 @@ and make_table_reader deref loc list_kind x =
error loc "Not a list or array of records"
in
let init_fields, init_bits, set_bit, check_bits, create_record =
- study_record deref fields
+ study_record ~ocaml_version deref fields
in
let cases =
Array.to_list (
@@ -1244,7 +1252,7 @@ and make_table_reader deref loc list_kind x =
`Line "let read =";
`Block [
`Line "(";
- `Block (make_reader deref ~tagged:false x.f_value);
+ `Block (make_reader deref ~tagged:false ~ocaml_version
x.f_value);
`Line ")";
`Block [ `Line "tag" ]
];
@@ -1339,7 +1347,8 @@ let make_ocaml_biniou_writer ~original_types deref is_rec
let1 let2 def =
]
]
-let make_ocaml_biniou_reader ~original_types deref is_rec let1 let2 def =
+let make_ocaml_biniou_reader ~original_types ~ocaml_version
+ deref is_rec let1 let2 def =
let x = match def.def_value with None -> assert false | Some x -> x in
let name = def.def_name in
let type_constraint = Ag_ox_emit.get_type_constraint ~original_types def in
@@ -1352,8 +1361,9 @@ let make_ocaml_biniou_reader ~original_types deref is_rec
let1 let2 def =
| true -> Some type_constraint
| false -> None
in
- let get_reader_expr = make_reader deref ~tagged:false ?type_annot x in
- let read_expr = make_reader deref ~tagged:true ?type_annot x in
+ let get_reader_expr =
+ make_reader deref ~tagged:false ~ocaml_version ?type_annot x in
+ let read_expr = make_reader deref ~tagged:true ~ocaml_version ?type_annot x
in
let eta_expand1 = is_rec && not (Ag_ox_emit.is_function get_reader_expr) in
let eta_expand2 = is_rec && not (Ag_ox_emit.is_function read_expr) in
let extra_param1, extra_args1 =
@@ -1389,7 +1399,8 @@ let get_let ~is_rec ~is_first =
else "let", "let"
else "and", "and"
-let make_ocaml_biniou_impl ~with_create ~original_types buf deref defs =
+let make_ocaml_biniou_impl ~with_create ~original_types ~ocaml_version
+ buf deref defs =
let ll =
List.map (
@@ -1407,7 +1418,7 @@ let make_ocaml_biniou_impl ~with_create ~original_types
buf deref defs =
map (
fun is_first def ->
let let1, let2 = get_let ~is_rec ~is_first in
- make_ocaml_biniou_reader
+ make_ocaml_biniou_reader ~ocaml_version
~original_types deref is_rec let1 let2 def
) l
in
@@ -1456,6 +1467,7 @@ let make_mli
let make_ml
~header ~opens ~with_typedefs ~with_create ~with_fundefs ~original_types
+ ~ocaml_version
ocaml_typedefs deref defs =
let buf = Buffer.create 1000 in
bprintf buf "%s\n" header;
@@ -1465,7 +1477,9 @@ let make_ml
if with_typedefs && with_fundefs then
bprintf buf "\n";
if with_fundefs then
- make_ocaml_biniou_impl ~with_create ~original_types buf deref defs;
+ make_ocaml_biniou_impl
+ ~with_create ~original_types ~ocaml_version
+ buf deref defs;
Buffer.contents buf
let make_ocaml_files
@@ -1479,6 +1493,7 @@ let make_ocaml_files
~type_aliases
~force_defaults
~name_overlap
+ ~ocaml_version
~pp_convs
atd_file out =
let ((head, m0), _) =
@@ -1528,7 +1543,7 @@ let make_ocaml_files
in
let ml =
make_ml ~header ~opens ~with_typedefs ~with_create ~with_fundefs
- ~original_types ocaml_typedefs
+ ~original_types ~ocaml_version ocaml_typedefs
(Ag_mapping.make_deref defs) defs
in
Ag_ox_emit.write_ocaml out mli ml
diff --git a/src/ag_oj_emit.ml b/src/ag_oj_emit.ml
index 6463fec..244a78c 100644
--- a/src/ag_oj_emit.ml
+++ b/src/ag_oj_emit.ml
@@ -34,6 +34,8 @@ type param = {
preprocess_input : string option;
(* intended for UTF-8 validation *)
+ ocaml_version: (int * int) option;
+
}
@@ -739,8 +741,11 @@ and make_record_writer p a record_kind =
`Line "Bi_outbuf.add_char ob '}';";
]
-let study_record deref fields =
- let unset_field_value = "Obj.magic 0.0" in
+let study_record p fields =
+ let unset_field_value = match p.ocaml_version with
+ | Some (maj, min) when (maj > 4 || maj = 4 && min >= 3) ->
+ "Obj.magic (Sys.opaque_identity 0.0)"
+ | _ -> "Obj.magic 0.0" in
let _, field_assignments =
Array.fold_right (fun field (i, field_assignments) ->
@@ -1233,7 +1238,7 @@ and make_deconstructed_reader p loc fields set_bit =
and make_record_reader p type_annot loc a record_kind =
let fields = get_fields p a in
let init_fields, init_bits, set_bit, check_bits, create_record =
- study_record p.deref fields
+ study_record p fields
in
let read_field =
@@ -1617,6 +1622,7 @@ let get_let ~is_rec ~is_first =
let make_ocaml_json_impl
~std ~unknown_field_handler ~constr_mismatch_handler
~with_create ~force_defaults ~preprocess_input ~original_types
+ ~ocaml_version
buf deref defs =
let p = {
deref = deref;
@@ -1625,6 +1631,7 @@ let make_ocaml_json_impl
constr_mismatch_handler = constr_mismatch_handler;
force_defaults = force_defaults;
preprocess_input;
+ ocaml_version;
} in
let ll =
List.map (
@@ -1692,6 +1699,7 @@ let make_ml
~header ~opens ~with_typedefs ~with_create ~with_fundefs
~std ~unknown_field_handler ~constr_mismatch_handler
~force_defaults ~preprocess_input ~original_types
+ ~ocaml_version
ocaml_typedefs deref defs =
let buf = Buffer.create 1000 in
bprintf buf "%s\n" header;
@@ -1704,6 +1712,7 @@ let make_ml
make_ocaml_json_impl
~std ~unknown_field_handler ~constr_mismatch_handler
~with_create ~force_defaults ~preprocess_input ~original_types
+ ~ocaml_version
buf deref defs;
Buffer.contents buf
@@ -1722,6 +1731,7 @@ let make_ocaml_files
~force_defaults
~preprocess_input
~name_overlap
+ ~ocaml_version
~pp_convs
atd_file out =
let ((head, m0), _) =
@@ -1772,6 +1782,7 @@ let make_ocaml_files
make_ml ~header ~opens ~with_typedefs ~with_create ~with_fundefs
~std ~unknown_field_handler ~constr_mismatch_handler
~force_defaults ~preprocess_input ~original_types
+ ~ocaml_version
ocaml_typedefs (Ag_mapping.make_deref defs) defs
in
Ag_ox_emit.write_ocaml out mli ml
diff --git a/src/ag_ov_emit.ml b/src/ag_ov_emit.ml
index de9d803..154ae04 100644
--- a/src/ag_ov_emit.ml
+++ b/src/ag_ov_emit.ml
@@ -473,6 +473,7 @@ let make_ocaml_files
~type_aliases
~force_defaults
~name_overlap
+ ~ocaml_version
~pp_convs
atd_file out =
let ((head, m0), _) =
diff --git a/src/ag_ox_emit.mli b/src/ag_ox_emit.mli
new file mode 100644
index 0000000..ea3d1d3
--- /dev/null
+++ b/src/ag_ox_emit.mli
@@ -0,0 +1,32 @@
+type 'a expr = (Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.mapping
+type 'a def = (Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.def
+type 'a grouped_defs = (bool * 'a def list) list
+
+val get_full_type_name : (_, _) Ag_mapping.def -> string
+
+val is_exportable : (_, _) Ag_mapping.def -> bool
+
+val make_record_creator
+ : ((Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.mapping
+ -> (Ag_ocaml.atd_ocaml_repr, 'b) Ag_mapping.mapping)
+ -> (Ag_ocaml.atd_ocaml_repr, 'a) Ag_mapping.def
+ -> string * string
+
+val opt_annot : string option -> string -> string
+
+val opt_annot_def : string option -> string -> string
+
+val insert_annot : string option -> string
+
+val get_type_constraint
+ : original_types:(string, string * int) Hashtbl.t
+ -> ('a, 'b) Ag_mapping.def
+ -> string
+
+val is_function : Ag_indent.t list -> bool
+
+val needs_type_annot : _ expr -> bool
+
+val check : _ grouped_defs -> unit
+
+val write_ocaml : [< `Files of string | `Stdout ] -> string -> string -> unit
diff --git a/test/test_atdgen_main.ml b/test/test_atdgen_main.ml
index 1a475a5..732f32b 100644
--- a/test/test_atdgen_main.ml
+++ b/test/test_atdgen_main.ml
@@ -63,10 +63,135 @@ let test_missing_tuple = (123, 4.56)
type internals1 = { int : int }
type internals2 = { float : float }
+ (* Obj.magic 0.0, opaque_identity, and record fields
+
+ Instead of using options (which may allocate), atdgen uses
+ a default value for references that denote record fields that may
+ not yet have been deserialized.
+
+ For example, consider the following example in the test.ml
+ generated code:
+
+type extended = {
+ b0x: int;
+ b1x: bool;
+ b2x: string;
+ b3x: string option;
+ b4x: string option;
+ b5x: float
+}
+
+let get_extended_reader = (
+ fun tag ->
+ if tag <> 21 then Ag_ob_run.read_error () else
+ fun ib ->
+ let field_b0x = ref (Obj.magic (Sys.opaque_identity 0.0)) in
+ let field_b1x = ref (Obj.magic (Sys.opaque_identity 0.0)) in
+ let field_b2x = ref (Obj.magic (Sys.opaque_identity 0.0)) in
+ let field_b3x = ref (None) in
+ let field_b4x = ref (Obj.magic (Sys.opaque_identity 0.0)) in
+ let field_b5x = ref (0.5) in
+ let bits0 = ref 0 in
+ let len = Bi_vint.read_uvint ib in
+ for i = 1 to len do
+ match Bi_io.read_field_hashtag ib with
+ | 21902 ->
+ field_b0x := (
+ (
+ Ag_ob_run.read_int
+ ) ib
+ );
+ bits0 := !bits0 lor 0x1;
+ | 21903 ->
+ field_b1x := (
+ (
+ Ag_ob_run.read_bool
+ ) ib
+ );
+ bits0 := !bits0 lor 0x2;
+ (* ... CODE ELIDED HERE ... *)
+ | 21907 ->
+ field_b5x := (
+ (
+ Ag_ob_run.read_float64
+ ) ib
+ );
+ | _ -> Bi_io.skip ib
+ done;
+ if !bits0 <> 0xf then Ag_ob_run.missing_fields
+ [| !bits0 |] [| "b0"; "b1"; "b2"; "b4" |];
+ (
+ {
+ b0x = !field_b0x;
+ b1x = !field_b1x;
+ b2x = !field_b2x;
+ b3x = !field_b3x;
+ b4x = !field_b4x;
+ b5x = !field_b5x;
+ }
+ : extended)
+
+ # Why Obj.magic?
+
+ At code generation time we do not have a default
+ value for the type of this field (we don't know what the type
+ is), so we create one out of thin air with Obj.magic
+
+ # Why 0.0?
+
+ Atdgen does not run the type-checker, so it does not a-priori
+ know if the field type is float (it may be a type alias of
+ "float" or even depend on a functor parameter).
+
+ If the type *is* float and the type-checker notices it
+ statically, then it may allocate an unboxed float reference, and
+ in particular unbox the default value passed at reference create
+ time. If this default value was *not* a float, then the code could
+ segfault. So in this case we must use a float value.
+
+ If the type is *not* float, then passing a float value is still
+ correct: the compiler will not try to unbox it, so a (word-sized)
+ pointer will be stored in the reference.
+
+ # Why Sys.opaque_identity?
+
+ Starting from 4.03, the compiler is more clever at assuming
+ things from values. When it sees the constant 0.0, it will infer
+ in particular that the reference contains a float (so it may
+ decide to unbox it!), etc. Notice that the compiler makes just
+ the same assumptions about (Obj.magic 0.0) than about 0.0, the
+ magic changes the type but not the value.
+
+ Also in 4.03, the Sys.opaque_identity function was added in the
+ Sys module; it is a compiler primitive of type ('a -> 'a) that
+ prevents the compiler from assuming anything about its return value.
+
+ In practice, using Sys.opaque_identity here avoids the segfault
+ that happened without it on 4.03. Note that this may not be
+ enough; in particular, (Sys.opaque_identity 0.0) is still
+ recognizeably a value of "float" type to the compiler (only the
+ value is unknown), so it would be legal for the compiler to still
+ decide to unbox in the future!
+
+ The long-term solution would be to stop using these unsafe
+ Obj.magic and use an option type to store the reference fields in
+ this case. This would be a more invasive change to the
+ implementation.
+ *)
+
let test_ocaml_internals () =
section "ocaml internals";
- let int = ref (Obj.magic 0.0) in
+ let opaque_identity =
+ (* neat trick to fallback to just the identity if we are using
+ a <4.03 version and Sys.opaque_identity is not available; found
+ in
+
https://github.com/LaurentMazare/tensorflow-ocaml/commit/111b4727cec992bab8bc67c22ccc8c31942ffbb2
*)
+ let opaque_identity x = x in
+ ignore opaque_identity;
+ let open Sys in opaque_identity in
+
+ let int = ref (Obj.magic (opaque_identity 0.0)) in
Gc.compact ();
int := 123;
Gc.compact ();
--
Alioth's /usr/local/bin/git-commit-notice on
/srv/git.debian.org/git/pkg-ocaml-maint/packages/atdgen.git
_______________________________________________
Pkg-ocaml-maint-commits mailing list
Pkg-ocaml-maint-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-ocaml-maint-commits
