diff options
62 files changed, 474 insertions, 378 deletions
@@ -30,6 +30,11 @@ Working version (KC Sivaramakrishnan, review by Stephen Dolan, Gabriel Scherer, and Xavier Leroy) +- #9569: Add `Val_none`, `Some_val`, `Is_none`, `Is_some`, `caml_alloc_some`, + and `Tag_some`. + (Nicolás Ojeda Bär, review by Stephen Dolan, Gabriel Scherer, Mark Shinwell, + and Xavier Leroy) + ### Code generation and optimizations: - #9441: Add RISC-V RV64G native-code backend. @@ -44,6 +49,9 @@ Working version - #9075: define to_rev_seq in Set and Map modules. (Sébastien Briais, review by Gabriel Scherer and Nicolás Ojeda Bär) +- #9561: Unbox Unix.gettimeofday and Unix.time + (Stephen Dolan, review by David Allsopp) + - #9571: Make at_exit and Printexc.register_printer thread-safe. (Guillaume Munch-Maccagnoni, review by Gabriel Scherer and Xavier Leroy) @@ -96,6 +104,12 @@ Working version - #9604: refactoring of the ocamltest codebase. (Nicolás Ojeda Bär, review by Gabriel Scherer and Sébastien Hinderer) +- #9498, #9511: make the pattern-matching analyzer more robust to + or-pattern explosion, by stopping after the first counter-example to + exhaustivity + (Gabriel Scherer, review by Luc Maranget, Thomas Refis and Florian Angeletti, + report by Alex Fedoseev through Hongbo Zhang) + ### Build system: - #9332, #9518, #9529: Cease storing C dependencies in the codebase. C @@ -133,7 +147,7 @@ OCaml 4.11 For instance, "val f: #F(X).t -> unit" is now allowed. (Florian Angeletti, review by Gabriel Scherer, suggestion by Leo White) -- #7364, #2188, #9609: improvement of the unboxability check for types +- #7364, #2188, #9592, #9609: improvement of the unboxability check for types with a single constructor. Mutually-recursive type declarations can now contain unboxed types. This is based on the paper https://arxiv.org/abs/1811.02300 @@ -303,6 +317,13 @@ OCaml 4.11 ### Tools: +- #6969: Argument -nocwd added to ocamldep + (Muskan Garg, review by Florian Angeletti) + +- #8676, #9594: turn debugger off in programs launched by the program + being debugged + (Xavier Leroy, report by Michael Soegtrop, review by Gabriel Scherer) + - #9057: aid debugging the debugger by preserving backtraces of unhandled exceptions. (David Allsopp, review by Gabriel Scherer) @@ -332,9 +353,6 @@ OCaml 4.11 to the toplevel. (Gabriel Scherer, review by Armaël Guéneau) -- #6969: Argument -nocwd added to ocamldep - (Muskan Garg, review by Florian Angeletti) - - #9207, #9210: fix ocamlyacc to work correctly with up to 255 entry points to the grammar. (Andreas Abel, review by Xavier Leroy) @@ -377,6 +395,9 @@ OCaml 4.11 warnings for consistency. (Muskan Garg, review by Gabriel Scherer and Florian Angeletti) +- #7708, #9580: Ensure Stdlib documentation index refers to Stdlib. + (Stephen Dolan, review by Florian Angeletti, report by Hannes Mehnert) + ### Compiler user-interface and warnings: - GPR#1664: make -output-complete-obj link the runtime native c libraries when diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index ca9b2fe277..165347c9f7 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -178,18 +178,12 @@ let rec expr_size env = function let transl_constant dbg = function | Uconst_int n -> int_const dbg n - | Uconst_ptr n -> - if n <= max_repr_int && n >= min_repr_int - then Cconst_int((n lsl 1) + 1, dbg) - else Cconst_natint - (Nativeint.add (Nativeint.shift_left (Nativeint.of_int n) 1) 1n, - dbg) | Uconst_ref (label, _) -> Cconst_symbol (label, dbg) let emit_constant cst cont = match cst with - | Uconst_int n | Uconst_ptr n -> + | Uconst_int n -> cint_const n :: cont | Uconst_ref (sym, _) -> @@ -435,7 +429,7 @@ let rec transl env e = Cphantom_const_symbol sym | Uphantom_read_symbol_field { sym; field; } -> Cphantom_read_symbol_field { sym; field; } - | Uphantom_const (Uconst_int i) | Uphantom_const (Uconst_ptr i) -> + | Uphantom_const (Uconst_int i) -> Cphantom_const_int (targetint_const i) | Uphantom_var var -> Cphantom_var var | Uphantom_read_field { var; field; } -> @@ -1225,9 +1219,9 @@ and transl_if env (approx : then_else) (then_dbg : Debuginfo.t) then_ (else_dbg : Debuginfo.t) else_ = match cond with - | Uconst (Uconst_ptr 0) -> else_ - | Uconst (Uconst_ptr 1) -> then_ - | Uifthenelse (arg1, arg2, Uconst (Uconst_ptr 0)) -> + | Uconst (Uconst_int 0) -> else_ + | Uconst (Uconst_int 1) -> then_ + | Uifthenelse (arg1, arg2, Uconst (Uconst_int 0)) -> (* CR mshinwell: These Debuginfos will flow through from Clambda *) let inner_dbg = Debuginfo.none in let ifso_dbg = Debuginfo.none in @@ -1242,7 +1236,7 @@ and transl_if env (approx : then_else) inner_dbg arg2 then_dbg then_ else_dbg else_ - | Uifthenelse (arg1, Uconst (Uconst_ptr 1), arg2) -> + | Uifthenelse (arg1, Uconst (Uconst_int 1), arg2) -> let inner_dbg = Debuginfo.none in let ifnot_dbg = Debuginfo.none in transl_sequor env approx @@ -1261,13 +1255,13 @@ and transl_if env (approx : then_else) dbg arg else_dbg else_ then_dbg then_ - | Uifthenelse (Uconst (Uconst_ptr 1), ifso, _) -> + | Uifthenelse (Uconst (Uconst_int 1), ifso, _) -> let ifso_dbg = Debuginfo.none in transl_if env approx ifso_dbg ifso then_dbg then_ else_dbg else_ - | Uifthenelse (Uconst (Uconst_ptr 0), _, ifnot) -> + | Uifthenelse (Uconst (Uconst_int 0), _, ifnot) -> let ifnot_dbg = Debuginfo.none in transl_if env approx ifnot_dbg ifnot diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml index aa8d8c5620..984ddf2207 100644 --- a/bytecomp/emitcode.ml +++ b/bytecomp/emitcode.ml @@ -77,7 +77,6 @@ exception AsInt let const_as_int = function | Const_base(Const_int i) -> i | Const_base(Const_char c) -> Char.code c - | Const_pointer i -> i | _ -> raise AsInt let is_immed i = immed_min <= i && i <= immed_max @@ -240,10 +239,6 @@ let emit_instr = function else (out opCONSTINT; out_int i) | Const_base(Const_char c) -> out opCONSTINT; out_int (Char.code c) - | Const_pointer i -> - if i >= 0 && i <= 3 - then out (opCONST0 + i) - else (out opCONSTINT; out_int i) | Const_block(t, []) -> if t = 0 then out opATOM0 else (out opATOM; out_int t) | _ -> @@ -378,10 +373,6 @@ let rec emit = function else (out opPUSHCONSTINT; out_int i) | Const_base(Const_char c) -> out opPUSHCONSTINT; out_int(Char.code c) - | Const_pointer i -> - if i >= 0 && i <= 3 - then out (opPUSHCONST0 + i) - else (out opPUSHCONSTINT; out_int i) | Const_block(t, []) -> if t = 0 then out opPUSHATOM0 else (out opPUSHATOM; out_int t) | _ -> diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 2a56f4f68a..28bb93c325 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -222,7 +222,6 @@ let rec transl_const = function | Const_base(Const_int32 i) -> Obj.repr i | Const_base(Const_int64 i) -> Obj.repr i | Const_base(Const_nativeint i) -> Obj.repr i - | Const_pointer i -> Obj.repr i | Const_immstring s -> Obj.repr s | Const_block(tag, fields) -> let block = Obj.new_block tag (List.length fields) in @@ -14935,6 +14935,19 @@ if test "x$ac_cv_func_putenv" = xyes; then : fi +## setenv and unsetenv + +ac_fn_c_check_func "$LINENO" "setenv" "ac_cv_func_setenv" +if test "x$ac_cv_func_setenv" = xyes; then : + ac_fn_c_check_func "$LINENO" "unsetenv" "ac_cv_func_unsetenv" +if test "x$ac_cv_func_unsetenv" = xyes; then : + $as_echo "#define HAS_SETENV_UNSETENV 1" >>confdefs.h + +fi + +fi + + ## newlocale() and <locale.h> # Note: the detection fails on msvc so we hardcode the result # (should be debugged later) diff --git a/configure.ac b/configure.ac index 4934edf71d..9ba91050f9 100644 --- a/configure.ac +++ b/configure.ac @@ -1446,6 +1446,11 @@ AS_CASE([$host], AC_CHECK_FUNC([putenv], [AC_DEFINE([HAS_PUTENV])]) +## setenv and unsetenv + +AC_CHECK_FUNC([setenv], + [AC_CHECK_FUNC([unsetenv], [AC_DEFINE([HAS_SETENV_UNSETENV])])]) + ## newlocale() and <locale.h> # Note: the detection fails on msvc so we hardcode the result # (should be debugged later) diff --git a/lambda/lambda.ml b/lambda/lambda.ml index af9abac469..139951b24a 100644 --- a/lambda/lambda.ml +++ b/lambda/lambda.ml @@ -220,7 +220,6 @@ let equal_value_kind x y = type structured_constant = Const_base of constant - | Const_pointer of int | Const_block of int * structured_constant list | Const_float_array of string list | Const_immstring of string @@ -355,7 +354,9 @@ type program = required_globals : Ident.Set.t; code : lambda } -let const_unit = Const_pointer 0 +let const_int n = Const_base (Const_int n) + +let const_unit = const_int 0 let lambda_unit = Lconst const_unit diff --git a/lambda/lambda.mli b/lambda/lambda.mli index 10bbf85979..f0a51b5c1b 100644 --- a/lambda/lambda.mli +++ b/lambda/lambda.mli @@ -212,7 +212,6 @@ val equal_boxed_integer : boxed_integer -> boxed_integer -> bool type structured_constant = Const_base of constant - | Const_pointer of int | Const_block of int * structured_constant list | Const_float_array of string list | Const_immstring of string @@ -355,6 +354,7 @@ type program = val make_key: lambda -> lambda option val const_unit: structured_constant +val const_int : int -> structured_constant val lambda_unit: lambda val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda diff --git a/lambda/printlambda.ml b/lambda/printlambda.ml index e213d1e8ac..b5cd62b95b 100644 --- a/lambda/printlambda.ml +++ b/lambda/printlambda.ml @@ -29,7 +29,6 @@ let rec struct_const ppf = function | Const_base(Const_int32 n) -> fprintf ppf "%lil" n | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n | Const_base(Const_nativeint n) -> fprintf ppf "%nin" n - | Const_pointer n -> fprintf ppf "%ia" n | Const_block(tag, []) -> fprintf ppf "[%i]" tag | Const_block(tag, sc1::scl) -> diff --git a/lambda/translclass.ml b/lambda/translclass.ml index 39f7612d2c..39cd2be836 100644 --- a/lambda/translclass.ml +++ b/lambda/translclass.ml @@ -65,7 +65,7 @@ let lfield v i = Lprim(Pfield (i, Pointer, Mutable), let transl_label l = share (Const_immstring l) let transl_meth_list lst = - if lst = [] then Lconst (Const_pointer 0) else + if lst = [] then Lconst (const_int 0) else share (Const_block (0, List.map (fun lab -> Const_immstring lab) lst)) @@ -382,7 +382,7 @@ let rec build_class_init ~scopes cla cstr super inh_init cl_init msubst top cl = Llet (Strict, Pgenval, inh, mkappl(oo_prim "inherits", narrow_args @ [path_lam; - Lconst(Const_pointer(if top then 1 else 0))]), + Lconst(const_int (if top then 1 else 0))]), Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init))) | _ -> let core cl_init = @@ -550,7 +550,7 @@ let rec builtin_meths self env env2 body = | Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self -> "var", [Lvar n] | Lprim(Pfield(n, _, _), [Lvar e], _) when Ident.same e env -> - "env", [Lvar env2; Lconst(Const_pointer n)] + "env", [Lvar env2; Lconst(const_int n)] | Lsend(Self, met, Lvar s, [], _) when List.mem s self -> "meth", [met] | _ -> raise Not_found @@ -621,7 +621,7 @@ module M = struct | "send_env" -> SendEnv | "send_meth" -> SendMeth | _ -> assert false - in Lconst(Const_pointer(Obj.magic tag)) :: args + in Lconst(const_int (Obj.magic tag)) :: args end open M diff --git a/lambda/translcore.ml b/lambda/translcore.ml index 46f33f139d..1edfebd4ac 100644 --- a/lambda/translcore.ml +++ b/lambda/translcore.ml @@ -64,7 +64,7 @@ let transl_extension_constructor ~scopes env path ext = Text_decl _ -> Lprim (Pmakeblock (Obj.object_tag, Immutable, None), [Lconst (Const_base (Const_string (name, ext.ext_loc, None))); - Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)], + Lprim (prim_fresh_oo_id, [Lconst (const_int 0)], loc)], loc) | Text_rebind(path, _lid) -> transl_extension_path loc env path @@ -331,7 +331,7 @@ and transl_exp0 ~scopes e = | _ -> assert false end else begin match cstr.cstr_tag with Cstr_constant n -> - Lconst(Const_pointer n) + Lconst(const_int n) | Cstr_unboxed -> (match ll with [v] -> v | _ -> assert false) | Cstr_block n -> @@ -354,15 +354,15 @@ and transl_exp0 ~scopes e = | Texp_variant(l, arg) -> let tag = Btype.hash_variant l in begin match arg with - None -> Lconst(Const_pointer tag) + None -> Lconst(const_int tag) | Some arg -> let lam = transl_exp ~scopes arg in try - Lconst(Const_block(0, [Const_base(Const_int tag); + Lconst(Const_block(0, [const_int tag; extract_constant lam])) with Not_constant -> Lprim(Pmakeblock(0, Immutable, None), - [Lconst(Const_base(Const_int tag)); lam], + [Lconst(const_int tag); lam], of_location ~scopes e.exp_loc) end | Texp_record {fields; representation; extended_expression} -> diff --git a/lambda/translmod.ml b/lambda/translmod.ml index e7fb57d341..3cc1e25348 100644 --- a/lambda/translmod.ml +++ b/lambda/translmod.ml @@ -217,8 +217,8 @@ let undefined_location loc = let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in Lconst(Const_block(0, [Const_base(Const_string (fname, loc, None)); - Const_base(Const_int line); - Const_base(Const_int char)])) + const_int line; + const_int char])) exception Initialization_failure of unsafe_info @@ -242,9 +242,9 @@ let init_shape id modl = let init_v = match Ctype.expand_head env ty with {desc = Tarrow(_,_,_,_)} -> - Const_pointer 0 (* camlinternalMod.Function *) + const_int 0 (* camlinternalMod.Function *) | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t -> - Const_pointer 1 (* camlinternalMod.Lazy *) + const_int 1 (* camlinternalMod.Lazy *) | _ -> let not_a_function = Unsafe {reason=Unsafe_non_function; loc; subid } @@ -270,7 +270,7 @@ let init_shape id modl = | Sig_modtype(id, minfo, _) :: rem -> init_shape_struct (Env.add_modtype id minfo env) rem | Sig_class _ :: rem -> - Const_pointer 2 (* camlinternalMod.Class *) + const_int 2 (* camlinternalMod.Class *) :: init_shape_struct env rem | Sig_class_type _ :: rem -> init_shape_struct env rem diff --git a/lambda/translprim.ml b/lambda/translprim.ml index 0f05737018..4b380ca7c8 100644 --- a/lambda/translprim.ml +++ b/lambda/translprim.ml @@ -664,7 +664,7 @@ let lambda_of_prim prim_name prim loc args arg_exps = | Primitive (prim, arity), args when arity = List.length args -> Lprim(prim, args, loc) | External prim, args when prim = prim_sys_argv -> - Lprim(Pccall prim, Lconst (Const_pointer 0) :: args, loc) + Lprim(Pccall prim, Lconst (const_int 0) :: args, loc) | External prim, args -> Lprim(Pccall prim, args, loc) | Comparison(comp, knd), ([_;_] as args) -> diff --git a/manual/manual/cmds/intf-c.etex b/manual/manual/cmds/intf-c.etex index 169ef2ac00..e2dc203212 100644 --- a/manual/manual/cmds/intf-c.etex +++ b/manual/manual/cmds/intf-c.etex @@ -654,6 +654,9 @@ containing \var{v} and \var{w} in fields 1 and 2. false otherwise \item "Is_block("\var{v}")" is true if value \var{v} is a pointer to a block, and false if it is an immediate integer. +\item "Is_none("\var{v}")" is true if value \var{v} is "None". +\item "Is_some("\var{v}")" is true if value \var{v} (assumed to be of option +type) corresponds to the "Some" constructor. \end{itemize} \subsection{ss:c-int-ops}{Operations on integers} @@ -668,6 +671,7 @@ truth value of the C integer \var{x}. \item "Bool_val("\var{v}")" returns 0 if \var{v} is the OCaml boolean "false", 1 if \var{v} is "true". \item "Val_true", "Val_false" represent the OCaml booleans "true" and "false". +\item "Val_none" represents the OCaml value "None". \end{itemize} \subsection{ss:c-block-access}{Accessing blocks} @@ -723,6 +727,8 @@ of a value \var{v} of any boxed type (record or concrete data type). \item "caml_field_unboxable("\var{v}")" calls either "caml_field_unboxed" or "caml_field_boxed" according to the default representation of unboxable types in the current version of OCaml. +\item "Some_val("\var{v}")" returns the argument "\var{x}" of a value \var{v} of +the form "Some("\var{x}")". \end{itemize} The expressions "Field("\var{v}", "\var{n}")", "Byte("\var{v}", "\var{n}")" and @@ -791,6 +797,8 @@ any boxed type) whose field is the value \var{v}. \item "caml_alloc_unboxable("\var{v}")" calls either "caml_alloc_unboxed" or "caml_alloc_boxed" according to the default representation of unboxable types in the current version of OCaml. +\item "caml_alloc_some("\var{v}")" allocates a block representing +"Some("\var{v}")". \end{itemize} \subsubsection{sss:c-low-level-alloc}{Low-level interface} diff --git a/manual/manual/library/core.etex b/manual/manual/library/core.etex index 3d98163328..d30f0d4d22 100644 --- a/manual/manual/library/core.etex +++ b/manual/manual/library/core.etex @@ -27,7 +27,7 @@ indexed at the end of this report. \section{s:stdlib-module}{Module {\tt Stdlib}: the initially opened module} \begin{links} \item \ahref{libref/Stdlib.html}{Module \texttt{Stdlib}: the initially opened module} -\item \ahref{libref/Pervasives.html}{Module \texttt{Pervasives}: deprecated alias for Stdlib} +\item Module \texttt{Pervasives}: deprecated alias for Stdlib \end{links} \else { diff --git a/middle_end/clambda.ml b/middle_end/clambda.ml index 59402629fc..11b51bccb1 100644 --- a/middle_end/clambda.ml +++ b/middle_end/clambda.ml @@ -34,7 +34,6 @@ type ustructured_constant = and uconstant = | Uconst_ref of string * ustructured_constant option | Uconst_int of int - | Uconst_ptr of int and uphantom_defining_expr = | Uphantom_const of uconstant @@ -162,11 +161,8 @@ let compare_constants c1 c2 = match, because of string constants that must not be reshared. *) | Uconst_int n1, Uconst_int n2 -> Stdlib.compare n1 n2 - | Uconst_ptr n1, Uconst_ptr n2 -> Stdlib.compare n1 n2 | Uconst_ref _, _ -> -1 | Uconst_int _, Uconst_ref _ -> 1 - | Uconst_int _, Uconst_ptr _ -> -1 - | Uconst_ptr _, _ -> 1 let rec compare_constant_lists l1 l2 = match l1, l2 with diff --git a/middle_end/clambda.mli b/middle_end/clambda.mli index 9d74eb6655..600778ae92 100644 --- a/middle_end/clambda.mli +++ b/middle_end/clambda.mli @@ -34,7 +34,6 @@ type ustructured_constant = and uconstant = | Uconst_ref of string * ustructured_constant option | Uconst_int of int - | Uconst_ptr of int and uphantom_defining_expr = | Uphantom_const of uconstant diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index b81092572a..9a0b75db9c 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -242,8 +242,7 @@ let make_const_ref c = make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c, Some c)) let make_const_int n = make_const (Uconst_int n) -let make_const_ptr n = make_const (Uconst_ptr n) -let make_const_bool b = make_const_ptr(if b then 1 else 0) +let make_const_bool b = make_const_int(if b then 1 else 0) let make_integer_comparison cmp x y = let open Clambda_primitives in @@ -284,7 +283,7 @@ let simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg = let default = (Uprim(p, args, dbg), Value_unknown) in match approxs with (* int (or enumerated type) *) - | [ Value_const(Uconst_int n1 | Uconst_ptr n1) ] -> + | [ Value_const(Uconst_int n1) ] -> begin match p with | Pnot -> make_const_bool (n1 = 0) | Pnegint -> make_const_int (- n1) @@ -298,8 +297,8 @@ let simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg = | _ -> default end (* int (or enumerated type), int (or enumerated type) *) - | [ Value_const(Uconst_int n1 | Uconst_ptr n1); - Value_const(Uconst_int n2 | Uconst_ptr n2) ] -> + | [ Value_const(Uconst_int n1); + Value_const(Uconst_int n2) ] -> begin match p with | Psequand -> make_const_bool (n1 <> 0 && n2 <> 0) | Psequor -> make_const_bool (n1 <> 0 || n2 <> 0) @@ -498,7 +497,7 @@ let simplif_prim_pure ~backend fpc p (args, approxs) dbg = (* Kind test *) | Pisint, _, [a1] -> begin match a1 with - | Value_const(Uconst_int _ | Uconst_ptr _) -> make_const_bool true + | Value_const(Uconst_int _) -> make_const_bool true | Value_const(Uconst_ref _) -> make_const_bool false | Value_closure _ | Value_tuple _ -> make_const_bool false | _ -> (Uprim(p, args, dbg), Value_unknown) @@ -612,7 +611,7 @@ let rec substitute loc ((backend, fpc) as st) sb rn ulam = match sarg with | Uconst (Uconst_ref (_, Some (Uconst_block (tag, _)))) -> find_action sw.us_index_blocks sw.us_actions_blocks tag - | Uconst (Uconst_ptr tag) -> + | Uconst (Uconst_int tag) -> find_action sw.us_index_consts sw.us_actions_consts tag | _ -> None in @@ -668,7 +667,7 @@ let rec substitute loc ((backend, fpc) as st) sb rn ulam = (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2) | Uifthenelse(u1, u2, u3) -> begin match substitute loc st sb rn u1 with - Uconst (Uconst_ptr n) -> + Uconst (Uconst_int n) -> if n <> 0 then substitute loc st sb rn u2 else @@ -804,8 +803,7 @@ let direct_apply env fundesc ufunct uargs ~loc ~attribute = then app else Usequence(ufunct, app) -(* Add [Value_integer] or [Value_constptr] info to the approximation - of an application *) +(* Add [Value_integer] info to the approximation of an application *) let strengthen_approx appl approx = match approx_ulam appl with @@ -813,7 +811,7 @@ let strengthen_approx appl approx = intapprox | _ -> approx -(* If a term has approximation Value_integer or Value_constptr and is pure, +(* If a term has approximation Value_integer and is pure, replace it by an integer constant *) let check_constant_result ulam approx = @@ -880,7 +878,6 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = let rec transl = function | Const_base(Const_int n) -> Uconst_int n | Const_base(Const_char c) -> Uconst_int (Char.code c) - | Const_pointer n -> Uconst_ptr n | Const_block (tag, fields) -> str (Uconst_block (tag, List.map transl fields)) | Const_float_array sl -> @@ -1062,13 +1059,13 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32") | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin") | Backend_type -> - make_const_ptr 0 (* tag 0 is the same as Native here *) + make_const_int 0 (* tag 0 is the same as Native here *) in let arg, _approx = close env arg in let id = Ident.create_local "dummy" in Ulet(Immutable, Pgenval, VP.create id, arg, cst), approx | Lprim(Pignore, [arg], _loc) -> - let expr, approx = make_const_ptr 0 in + let expr, approx = make_const_int 0 in Usequence(fst (close env arg), expr), approx | Lprim((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _loc) -> close env arg @@ -1166,7 +1163,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = (Utrywith(ubody, VP.create id, uhandler), Value_unknown) | Lifthenelse(arg, ifso, ifnot) -> begin match close env arg with - (uarg, Value_const (Uconst_ptr n)) -> + (uarg, Value_const (Uconst_int n)) -> sequence_constant_expr uarg (close env (if n = 0 then ifnot else ifso)) | (uarg, _ ) -> @@ -1440,7 +1437,7 @@ let collect_exported_structured_constants a = Compilenv.add_exported_constant s; structured_constant c | Uconst_ref (_s, None) -> assert false (* Cannot be generated *) - | Uconst_int _ | Uconst_ptr _ -> () + | Uconst_int _ -> () and structured_constant = function | Uconst_block (_, ul) -> List.iter const ul | Uconst_float _ | Uconst_int32 _ diff --git a/middle_end/flambda/build_export_info.ml b/middle_end/flambda/build_export_info.ml index c0eb8913a7..a3cb96d251 100644 --- a/middle_end/flambda/build_export_info.ml +++ b/middle_end/flambda/build_export_info.ml @@ -171,7 +171,7 @@ end = struct | export_id -> export_id let new_unit_descr t = - new_descr t (Value_constptr 0) + new_descr t (Value_int 0) let add_approx t var approx = if Variable.Map.mem var t.var then begin @@ -199,12 +199,8 @@ end let descr_of_constant (c : Flambda.const) : Export_info.descr = match c with - (* [Const_pointer] is an immediate value of a type whose values may be - boxed (typically a variant type with both constant and non-constant - constructors). *) | Int i -> Value_int i | Char c -> Value_char c - | Const_pointer i -> Value_constptr i let descr_of_allocated_constant (c : Allocated_const.t) : Export_info.descr = match c with @@ -602,7 +598,6 @@ let build_transient ~(backend : (module Backend_intf.S)) | Value_mutable_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_float _ | Value_float_array _ | Value_string _ @@ -644,7 +639,6 @@ let build_transient ~(backend : (module Backend_intf.S)) | Value_mutable_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_float _ | Value_float_array _ | Value_string _ diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml index fd16b9c6d5..8df123f498 100644 --- a/middle_end/flambda/closure_conversion.ml +++ b/middle_end/flambda/closure_conversion.ml @@ -137,7 +137,6 @@ let rec declare_const t (const : Lambda.structured_constant) Names.const_int64 | Const_base (Const_nativeint c) -> register_const t (Allocated_const (Nativeint c)) Names.const_nativeint - | Const_pointer c -> Const (Const_pointer c), Names.const_ptr | Const_immstring c -> register_const t (Allocated_const (Immutable_string c)) Names.const_immstring @@ -162,9 +161,9 @@ let close_const t (const : Lambda.structured_constant) let lambda_const_bool b : Lambda.structured_constant = if b then - Const_pointer 1 + Lambda.const_int 1 else - Const_pointer 0 + Lambda.const_int 0 let lambda_const_int i : Lambda.structured_constant = Const_base (Const_int i) @@ -391,7 +390,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = let arg2 = close t env arg2 in let const_true = Variable.create Names.const_true in let cond = Variable.create Names.cond_sequor in - Flambda.create_let const_true (Const (Const_pointer 1)) + Flambda.create_let const_true (Const (Int 1)) (Flambda.create_let cond (Expr arg1) (If_then_else (cond, Var const_true, arg2))) | Lprim (Psequand, [arg1; arg2], _) -> @@ -399,7 +398,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = let arg2 = close t env arg2 in let const_false = Variable.create Names.const_false in let cond = Variable.create Names.const_sequand in - Flambda.create_let const_false (Const (Const_pointer 0)) + Flambda.create_let const_false (Const (Int 0)) (Flambda.create_let cond (Expr arg1) (If_then_else (cond, arg2, Var const_false))) | Lprim ((Psequand | Psequor), _, _) -> @@ -412,7 +411,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = close_let_bound_expression t var env arg in Flambda.create_let var defining_expr - (name_expr (Const (Const_pointer 0)) ~name:Names.unit) + (name_expr (Const (Int 0)) ~name:Names.unit) | Lprim (Pdirapply, [funct; arg], loc) | Lprim (Prevapply, [arg; funct], loc) -> let apply : Lambda.lambda_apply = @@ -448,7 +447,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = | Ostype_win32 -> lambda_const_bool (String.equal Sys.os_type "Win32") | Ostype_cygwin -> lambda_const_bool (String.equal Sys.os_type "Cygwin") | Backend_type -> - Lambda.Const_pointer 0 (* tag 0 is the same as Native *) + Lambda.const_int 0 (* tag 0 is the same as Native *) end in close t env diff --git a/middle_end/flambda/export_info.ml b/middle_end/flambda/export_info.ml index 22dbb6c583..dc47be5e1b 100644 --- a/middle_end/flambda/export_info.ml +++ b/middle_end/flambda/export_info.ml @@ -41,7 +41,6 @@ type descr = | Value_mutable_block of Tag.t * int | Value_int of int | Value_char of char - | Value_constptr of int | Value_float of float | Value_float_array of value_float_array | Value_boxed_int : 'a A.boxed_int * 'a -> descr @@ -113,8 +112,6 @@ let equal_descr (d1:descr) (d2:descr) : bool = i1 = i2 | Value_char c1, Value_char c2 -> c1 = c2 - | Value_constptr i1, Value_constptr i2 -> - i1 = i2 | Value_float f1, Value_float f2 -> f1 = f2 | Value_float_array s1, Value_float_array s2 -> @@ -129,12 +126,12 @@ let equal_descr (d1:descr) (d2:descr) : bool = | Value_set_of_closures s1, Value_set_of_closures s2 -> equal_set_of_closures s1 s2 | ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _ - | Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _ + | Value_char _ | Value_float _ | Value_float_array _ | Value_boxed_int _ | Value_string _ | Value_closure _ | Value_set_of_closures _ | Value_unknown_descr ), ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _ - | Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _ + | Value_char _ | Value_float _ | Value_float_array _ | Value_boxed_int _ | Value_string _ | Value_closure _ | Value_set_of_closures _ | Value_unknown_descr ) -> @@ -396,7 +393,6 @@ let print_raw_descr ppf descr = fprintf ppf "(Value_mutable-block (%a %d))" Tag.print tag i | Value_int i -> fprintf ppf "(Value_int %d)" i | Value_char c -> fprintf ppf "(Value_char %c)" c - | Value_constptr p -> fprintf ppf "(Value_constptr %d)" p | Value_float f -> fprintf ppf "(Value_float %.3f)" f | Value_float_array value_float_array -> fprintf ppf "(Value_float_array %a)" @@ -445,7 +441,6 @@ let print_approx_components ppf ~symbol_id ~values match descr with | Value_int i -> Format.pp_print_int ppf i | Value_char c -> fprintf ppf "%c" c - | Value_constptr i -> fprintf ppf "%ip" i | Value_block (tag, fields) -> fprintf ppf "[%a:%a]" Tag.print tag print_fields fields | Value_mutable_block (tag, size) -> diff --git a/middle_end/flambda/export_info.mli b/middle_end/flambda/export_info.mli index f93698be4f..4068a168d2 100644 --- a/middle_end/flambda/export_info.mli +++ b/middle_end/flambda/export_info.mli @@ -44,7 +44,6 @@ type descr = | Value_mutable_block of Tag.t * int | Value_int of int | Value_char of char - | Value_constptr of int | Value_float of float | Value_float_array of value_float_array | Value_boxed_int : 'a A.boxed_int * 'a -> descr diff --git a/middle_end/flambda/export_info_for_pack.ml b/middle_end/flambda/export_info_for_pack.ml index ebed559369..f4baa29b82 100644 --- a/middle_end/flambda/export_info_for_pack.ml +++ b/middle_end/flambda/export_info_for_pack.ml @@ -99,7 +99,6 @@ let import_descr_for_pack units pack (descr : Export_info.descr) match descr with | Value_int _ | Value_char _ - | Value_constptr _ | Value_string _ | Value_float _ | Value_float_array _ diff --git a/middle_end/flambda/flambda.ml b/middle_end/flambda/flambda.ml index 2866c697e0..55ffb87dad 100644 --- a/middle_end/flambda/flambda.ml +++ b/middle_end/flambda/flambda.ml @@ -24,7 +24,6 @@ type call_kind = type const = | Int of int | Char of char - | Const_pointer of int type apply = { func : Variable.t; @@ -428,7 +427,6 @@ and print_const ppf (c : const) = match c with | Int n -> fprintf ppf "%i" n | Char c -> fprintf ppf "%C" c - | Const_pointer n -> fprintf ppf "%ia" n let print_function_declarations ppf (fd : function_declarations) = let funs ppf = @@ -1189,11 +1187,8 @@ let compare_const (c1:const) (c2:const) = match c1, c2 with | Int i1, Int i2 -> compare i1 i2 | Char i1, Char i2 -> Char.compare i1 i2 - | Const_pointer i1, Const_pointer i2 -> compare i1 i2 - | Int _, (Char _ | Const_pointer _) -> -1 - | (Char _ | Const_pointer _), Int _ -> 1 - | Char _, Const_pointer _ -> -1 - | Const_pointer _, Char _ -> 1 + | Int _, Char _ -> -1 + | Char _, Int _ -> 1 let compare_constant_defining_value_block_field (c1:constant_defining_value_block_field) diff --git a/middle_end/flambda/flambda.mli b/middle_end/flambda/flambda.mli index 325c15ee1c..8665b5a411 100644 --- a/middle_end/flambda/flambda.mli +++ b/middle_end/flambda/flambda.mli @@ -29,10 +29,6 @@ type const = | Int of int | Char of char (** [Char] is kept separate from [Int] to improve printing *) - | Const_pointer of int - (** [Const_pointer] is an immediate value of a type whose values may be - boxed (typically a variant type with both constant and non-constant - constructors). *) (** The application of a function to a list of arguments. *) type apply = { diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml index 882c198e48..c28167e042 100644 --- a/middle_end/flambda/flambda_to_clambda.ml +++ b/middle_end/flambda/flambda_to_clambda.ml @@ -232,7 +232,6 @@ let to_clambda_const env (const : Flambda.constant_defining_value_block_field) | Symbol symbol -> to_clambda_symbol' env symbol | Const (Int i) -> Uconst_int i | Const (Char c) -> Uconst_int (Char.code c) - | Const (Const_pointer i) -> Uconst_ptr i let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda = match flam with @@ -357,7 +356,6 @@ let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda = and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda = match named with | Symbol sym -> to_clambda_symbol env sym - | Const (Const_pointer n) -> Uconst (Uconst_ptr n) | Const (Int n) -> Uconst (Uconst_int n) | Const (Char c) -> Uconst (Uconst_int (Char.code c)) | Allocated_const _ -> @@ -615,7 +613,7 @@ let to_clambda_initialize_symbol t env symbol fields : Clambda.ulambda = Debuginfo.none) in match fields with - | [] -> Uconst (Uconst_ptr 0) + | [] -> Uconst (Uconst_int 0) | h :: t -> List.fold_left (fun acc (p, field) -> Clambda.Usequence (build_setfield (p, field), acc)) @@ -684,7 +682,6 @@ let to_clambda_program t env constants (program : Flambda.program) = match const with | Int i -> i | Char c -> Char.code c - | Const_pointer i -> i in Some (Clambda.Uconst_field_int n) | Some (Flambda.Symbol sym) -> @@ -708,7 +705,7 @@ let to_clambda_program t env constants (program : Flambda.program) = let e2, constants, preallocated_blocks = loop env constants program in Usequence (e1, e2), constants, preallocated_blocks | End _ -> - Uconst (Uconst_ptr 0), constants, [] + Uconst (Uconst_int 0), constants, [] in loop env constants program.program_body diff --git a/middle_end/flambda/import_approx.ml b/middle_end/flambda/import_approx.ml index 64fbbb8bff..f5c004aa6b 100644 --- a/middle_end/flambda/import_approx.ml +++ b/middle_end/flambda/import_approx.ml @@ -126,7 +126,6 @@ let rec import_ex ex = | Value_unknown_descr -> A.value_unknown Other | Value_int i -> A.value_int i | Value_char c -> A.value_char c - | Value_constptr i -> A.value_constptr i | Value_float f -> A.value_float f | Value_float_array float_array -> begin match float_array.contents with diff --git a/middle_end/flambda/inline_and_simplify.ml b/middle_end/flambda/inline_and_simplify.ml index 33d27e5d7b..538bf9ff3e 100644 --- a/middle_end/flambda/inline_and_simplify.ml +++ b/middle_end/flambda/inline_and_simplify.ml @@ -175,7 +175,6 @@ let simplify_const (const : Flambda.const) = match const with | Int i -> A.value_int i | Char c -> A.value_char c - | Const_pointer i -> A.value_constptr i let approx_for_allocated_const (const : Allocated_const.t) = match const with @@ -1213,10 +1212,10 @@ and simplify env r (tree : Flambda.t) : Flambda.t * R.t = if arg is not effectful we can also drop it. *) simplify_free_variable env arg ~f:(fun env arg arg_approx -> begin match arg_approx.descr with - | Value_constptr 0 | Value_int 0 -> (* Constant [false]: keep [ifnot] *) + | Value_int 0 -> (* Constant [false]: keep [ifnot] *) let ifnot, r = simplify env r ifnot in ifnot, R.map_benefit r B.remove_branch - | Value_constptr _ | Value_int _ + | Value_int _ | Value_block _ -> (* Constant [true]: keep [ifso] *) let ifso, r = simplify env r ifso in ifso, R.map_benefit r B.remove_branch diff --git a/middle_end/flambda/remove_unused_arguments.ml b/middle_end/flambda/remove_unused_arguments.ml index f70da729ae..21ce9670e7 100644 --- a/middle_end/flambda/remove_unused_arguments.ml +++ b/middle_end/flambda/remove_unused_arguments.ml @@ -35,7 +35,7 @@ let remove_params unused (fun_decl: Flambda.function_declaration) in let body = List.fold_left (fun body param -> - Flambda.create_let (Parameter.var param) (Const (Const_pointer 0)) body) + Flambda.create_let (Parameter.var param) (Const (Int 0)) body) fun_decl.body unused_params in diff --git a/middle_end/flambda/simple_value_approx.ml b/middle_end/flambda/simple_value_approx.ml index d527674f87..d2e0b21ef9 100644 --- a/middle_end/flambda/simple_value_approx.ml +++ b/middle_end/flambda/simple_value_approx.ml @@ -48,7 +48,6 @@ and descr = | Value_block of Tag.t * t array | Value_int of int | Value_char of char - | Value_constptr of int | Value_float of float option | Value_boxed_int : 'a boxed_int * 'a -> descr | Value_set_of_closures of value_set_of_closures @@ -171,7 +170,6 @@ let print_function_declarations ppf (fd : function_declarations) = let rec print_descr ppf = function | Value_int i -> Format.pp_print_int ppf i | Value_char c -> Format.fprintf ppf "%c" c - | Value_constptr i -> Format.fprintf ppf "%ia" i | Value_block (tag,fields) -> let p ppf fields = Array.iter (fun v -> Format.fprintf ppf "%a@ " print v) fields in @@ -253,7 +251,6 @@ let augment_with_kind t (kind:Lambda.value_kind) = | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_boxed_int _ | Value_set_of_closures _ | Value_closure _ @@ -280,7 +277,6 @@ let augment_kind_with_approx t (kind:Lambda.value_kind) : Lambda.value_kind = let value_unknown reason = approx (Value_unknown reason) let value_int i = approx (Value_int i) let value_char i = approx (Value_char i) -let value_constptr i = approx (Value_constptr i) let value_float f = approx (Value_float (Some f)) let value_any_float = approx (Value_float None) let value_boxed_int bi i = approx (Value_boxed_int (bi,i)) @@ -392,19 +388,8 @@ let make_const_char n = let name = Internal_variable_names.const_char in name_expr_fst (make_const_char_named n) ~name -let make_const_ptr_named n : Flambda.named * t = - Const (Const_pointer n), value_constptr n -let make_const_ptr (n : int) = - let name = - match n with - | 0 -> Internal_variable_names.const_ptr_zero - | 1 -> Internal_variable_names.const_ptr_one - | _ -> Internal_variable_names.const_ptr - in - name_expr_fst (make_const_ptr_named n) ~name - let make_const_bool_named b : Flambda.named * t = - make_const_ptr_named (if b then 1 else 0) + make_const_int_named (if b then 1 else 0) let make_const_bool b = name_expr_fst (make_const_bool_named b) ~name:Internal_variable_names.const_bool @@ -444,9 +429,6 @@ let simplify t (lam : Flambda.t) : simplification_result = | Value_char n -> let const, approx = make_const_char n in const, Replaced_term, approx - | Value_constptr n -> - let const, approx = make_const_ptr n in - const, Replaced_term, approx | Value_float (Some f) -> let const, approx = make_const_float f in const, Replaced_term, approx @@ -472,9 +454,6 @@ let simplify_named t (named : Flambda.named) : simplification_result_named = | Value_char n -> let const, approx = make_const_char_named n in const, Replaced_term, approx - | Value_constptr n -> - let const, approx = make_const_ptr_named n in - const, Replaced_term, approx | Value_float (Some f) -> let const, approx = make_const_float_named f in const, Replaced_term, approx @@ -496,7 +475,6 @@ let simplify_var t : (Flambda.named * t) option = match t.descr with | Value_int n -> Some (make_const_int_named n) | Value_char n -> Some (make_const_char_named n) - | Value_constptr n -> Some (make_const_ptr_named n) | Value_float (Some f) -> Some (make_const_float_named f) | Value_boxed_int (t, i) -> Some (make_const_boxed_int_named t i) | Value_symbol sym -> Some (Symbol sym, t) @@ -559,14 +537,14 @@ let known t = | Value_unknown _ -> false | Value_string _ | Value_float_array _ | Value_bottom | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_set_of_closures _ | Value_closure _ + | Value_set_of_closures _ | Value_closure _ | Value_extern _ | Value_float _ | Value_boxed_int _ | Value_symbol _ -> true let useful t = match t.descr with | Value_unresolved _ | Value_unknown _ | Value_bottom -> false | Value_string _ | Value_float_array _ | Value_block _ | Value_int _ - | Value_char _ | Value_constptr _ | Value_set_of_closures _ + | Value_char _ | Value_set_of_closures _ | Value_float _ | Value_boxed_int _ | Value_closure _ | Value_extern _ | Value_symbol _ -> true @@ -576,7 +554,7 @@ let warn_on_mutation t = match t.descr with | Value_block(_, fields) -> Array.length fields > 0 | Value_string { contents = Some _ } - | Value_int _ | Value_char _ | Value_constptr _ + | Value_int _ | Value_char _ | Value_set_of_closures _ | Value_float _ | Value_boxed_int _ | Value_closure _ -> true | Value_string { contents = None } | Value_float_array _ @@ -601,7 +579,7 @@ let get_field t ~field_index:i : get_field_result = (* CR-someday mshinwell: This should probably return Unreachable in more cases. I added a couple more. *) | Value_bottom - | Value_int _ | Value_char _ | Value_constptr _ -> + | Value_int _ | Value_char _ -> (* Something seriously wrong is happening: either the user is doing something exceptionally unsafe, or it is an unreachable branch. We consider this as unreachable and mark the result accordingly. *) @@ -637,7 +615,7 @@ let check_approx_for_block t = | Value_block (tag, fields) -> Ok (tag, fields) | Value_bottom - | Value_int _ | Value_char _ | Value_constptr _ + | Value_int _ | Value_char _ | Value_float_array _ | Value_string _ | Value_float _ | Value_boxed_int _ | Value_set_of_closures _ | Value_closure _ @@ -687,8 +665,6 @@ let equal_floats f1 f2 = let rec meet_descr ~really_import_approx d1 d2 = match d1, d2 with | Value_int i, Value_int j when i = j -> d1 - | Value_constptr i, Value_constptr j when i = j -> - d1 | Value_symbol s1, Value_symbol s2 when Symbol.equal s1 s2 -> d1 | Value_extern e1, Value_extern e2 when Export_id.equal e1 e2 -> @@ -780,7 +756,7 @@ let check_approx_for_set_of_closures t : checked_approx_for_set_of_closures = to the set now out of scope. *) Ok (t.var, value_set_of_closures) | Value_closure _ | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_float _ | Value_boxed_int _ | Value_unknown _ + | Value_float _ | Value_boxed_int _ | Value_unknown _ | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ | Value_symbol _ -> Wrong @@ -818,7 +794,7 @@ let check_approx_for_closure_allowing_unresolved t symbol, value_set_of_closures) | Value_unresolved _ | Value_closure _ | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_float _ | Value_boxed_int _ | Value_unknown _ + | Value_float _ | Value_boxed_int _ | Value_unknown _ | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ | Value_symbol _ -> Wrong @@ -827,7 +803,7 @@ let check_approx_for_closure_allowing_unresolved t Unknown_because_of_unresolved_value value | Value_unresolved symbol -> Unresolved symbol | Value_set_of_closures _ | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_float _ | Value_boxed_int _ + | Value_float _ | Value_boxed_int _ | Value_bottom | Value_extern _ | Value_string _ | Value_float_array _ | Value_symbol _ -> Wrong @@ -866,7 +842,7 @@ let check_approx_for_float t : float option = | Value_unresolved _ | Value_unknown _ | Value_string _ | Value_float_array _ | Value_bottom | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_set_of_closures _ | Value_closure _ + | Value_set_of_closures _ | Value_closure _ | Value_extern _ | Value_boxed_int _ | Value_symbol _ -> None @@ -883,7 +859,7 @@ let float_array_as_constant (t:value_float_array) : float list option = (Value_float None | Value_unresolved _ | Value_unknown _ | Value_string _ | Value_float_array _ | Value_bottom | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_set_of_closures _ | Value_closure _ + | Value_set_of_closures _ | Value_closure _ | Value_extern _ | Value_boxed_int _ | Value_symbol _) -> None) contents (Some []) @@ -895,7 +871,7 @@ let check_approx_for_string t : string option = | Value_unresolved _ | Value_unknown _ | Value_float_array _ | Value_bottom | Value_block _ | Value_int _ | Value_char _ - | Value_constptr _ | Value_set_of_closures _ | Value_closure _ + | Value_set_of_closures _ | Value_closure _ | Value_extern _ | Value_boxed_int _ | Value_symbol _ -> None @@ -913,11 +889,11 @@ let potentially_taken_const_switch_branch t branch = (* In theory symbol cannot contain integers but this shouldn't matter as this will always be an imported approximation *) Can_be_taken - | Value_constptr i | Value_int i when i = branch -> + | Value_int i when i = branch -> Must_be_taken | Value_char c when Char.code c = branch -> Must_be_taken - | Value_constptr _ | Value_int _ | Value_char _ -> + | Value_int _ | Value_char _ -> Cannot_be_taken | Value_block _ | Value_float _ | Value_float_array _ | Value_string _ | Value_closure _ | Value_set_of_closures _ @@ -931,7 +907,7 @@ let potentially_taken_block_switch_branch t tag = | Value_extern _ | Value_symbol _) -> Can_be_taken - | (Value_constptr _ | Value_int _| Value_char _) -> + | (Value_int _| Value_char _) -> Cannot_be_taken | Value_block (block_tag, _) when Tag.to_int block_tag = tag -> Must_be_taken diff --git a/middle_end/flambda/simple_value_approx.mli b/middle_end/flambda/simple_value_approx.mli index dd38652f5b..693e641ff6 100644 --- a/middle_end/flambda/simple_value_approx.mli +++ b/middle_end/flambda/simple_value_approx.mli @@ -124,7 +124,6 @@ and descr = private | Value_block of Tag.t * t array | Value_int of int | Value_char of char - | Value_constptr of int | Value_float of float option | Value_boxed_int : 'a boxed_int * 'a -> descr | Value_set_of_closures of value_set_of_closures @@ -248,7 +247,6 @@ val value_mutable_float_array : size:int -> t val value_immutable_float_array : t array -> t val value_string : int -> string option -> t val value_boxed_int : 'i boxed_int -> 'i -> t -val value_constptr : int -> t val value_block : Tag.t -> t array -> t val value_extern : Export_id.t -> t val value_symbol : Symbol.t -> t @@ -280,14 +278,12 @@ val value_set_of_closures together with an Flambda expression representing it. *) val make_const_int : int -> Flambda.t * t val make_const_char : char -> Flambda.t * t -val make_const_ptr : int -> Flambda.t * t val make_const_bool : bool -> Flambda.t * t val make_const_float : float -> Flambda.t * t val make_const_boxed_int : 'i boxed_int -> 'i -> Flambda.t * t val make_const_int_named : int -> Flambda.named * t val make_const_char_named : char -> Flambda.named * t -val make_const_ptr_named : int -> Flambda.named * t val make_const_bool_named : bool -> Flambda.named * t val make_const_float_named : float -> Flambda.named * t val make_const_boxed_int_named : 'i boxed_int -> 'i -> Flambda.named * t diff --git a/middle_end/flambda/simplify_common.ml b/middle_end/flambda/simplify_common.ml index fcbbcfbcba..021ec68aa8 100644 --- a/middle_end/flambda/simplify_common.ml +++ b/middle_end/flambda/simplify_common.ml @@ -35,11 +35,6 @@ let const_char_expr expr c = let (new_expr, approx) = A.make_const_char_named c in new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero else expr, A.value_char c, C.Benefit.zero -let const_ptr_expr expr n = - if Effect_analysis.no_effects_named expr then - let (new_expr, approx) = A.make_const_ptr_named n in - new_expr, approx, C.Benefit.remove_code_named expr C.Benefit.zero - else expr, A.value_constptr n, C.Benefit.zero let const_bool_expr expr b = const_int_expr expr (if b then 1 else 0) let const_float_expr expr f = diff --git a/middle_end/flambda/simplify_common.mli b/middle_end/flambda/simplify_common.mli index c667bfffe5..ff1016717c 100644 --- a/middle_end/flambda/simplify_common.mli +++ b/middle_end/flambda/simplify_common.mli @@ -42,11 +42,6 @@ val const_bool_expr -> bool -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t -val const_ptr_expr - : Flambda.named - -> int - -> Flambda.named * Simple_value_approx.t * Inlining_cost.Benefit.t - val const_float_expr : Flambda.named -> float diff --git a/middle_end/flambda/simplify_primitives.ml b/middle_end/flambda/simplify_primitives.ml index a228fe825f..c7344db23c 100644 --- a/middle_end/flambda/simplify_primitives.ml +++ b/middle_end/flambda/simplify_primitives.ml @@ -40,7 +40,7 @@ let phys_equal (approxs:A.t list) = let is_known_to_be_some_kind_of_int (arg:A.descr) = match arg with - | Value_int _ | Value_char _ | Value_constptr _ -> true + | Value_int _ | Value_char _ -> true | Value_block (_, _) | Value_float _ | Value_set_of_closures _ | Value_closure _ | Value_string _ | Value_float_array _ | A.Value_boxed_int _ | Value_unknown _ | Value_extern _ @@ -50,13 +50,13 @@ let is_known_to_be_some_kind_of_block (arg:A.descr) = match arg with | Value_block _ | Value_float _ | Value_float_array _ | A.Value_boxed_int _ | Value_closure _ | Value_string _ -> true - | Value_set_of_closures _ | Value_int _ | Value_char _ | Value_constptr _ + | Value_set_of_closures _ | Value_int _ | Value_char _ | Value_unknown _ | Value_extern _ | Value_symbol _ | Value_unresolved _ | Value_bottom -> false let rec structurally_different (arg1:A.t) (arg2:A.t) = match arg1.descr, arg2.descr with - | (Value_int n1 | Value_constptr n1), (Value_int n2 | Value_constptr n2) + | (Value_int n1), (Value_int n2) when n1 <> n2 -> true | Value_block (tag1, fields1), Value_block (tag2, fields2) -> @@ -171,6 +171,7 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs) | Pnot -> S.const_bool_expr expr (x = 0) | Pnegint -> S.const_int_expr expr (-x) | Pbswap16 -> S.const_int_expr expr (S.swap16 x) + | Pisint -> S.const_bool_expr expr true | Poffsetint y -> S.const_int_expr expr (x + y) | Pfloatofint when fpc -> S.const_float_expr expr (float_of_int x) | Pbintofint Pnativeint -> @@ -179,7 +180,7 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs) | Pbintofint Pint64 -> S.const_boxed_int_expr expr Int64 (Int64.of_int x) | _ -> expr, A.value_unknown Other, C.Benefit.zero end - | [(Value_int x | Value_constptr x); (Value_int y | Value_constptr y)] -> + | [Value_int x; Value_int y] -> let shift_precond = 0 <= y && y < 8 * size_int in begin match p with | Paddint -> S.const_int_expr expr (x + y) @@ -204,15 +205,6 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs) | Pcompare_ints -> S.const_int_expr expr (Char.compare x y) | _ -> expr, A.value_unknown Other, C.Benefit.zero end - | [Value_constptr x] -> - begin match p with - (* [Pidentity] should probably never appear, but is here for - completeness. *) - | Pnot -> S.const_bool_expr expr (x = 0) - | Pisint -> S.const_bool_expr expr true - | Poffsetint y -> S.const_ptr_expr expr (x + y) - | _ -> expr, A.value_unknown Other, C.Benefit.zero - end | [Value_float (Some x)] when fpc -> begin match p with | Pintoffloat -> S.const_int_expr expr (int_of_float x) @@ -258,7 +250,7 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs) when (is_pstring_length p || is_pbytes_length p) -> S.const_int_expr expr size | [Value_string { size; contents = Some s }; - (Value_int x | Value_constptr x)] when x >= 0 && x < size -> + (Value_int x)] when x >= 0 && x < size -> begin match p with | Pstringrefu | Pstringrefs @@ -268,14 +260,14 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs) | _ -> expr, A.value_unknown Other, C.Benefit.zero end | [Value_string { size; contents = None }; - (Value_int x | Value_constptr x)] + (Value_int x)] when x >= 0 && x < size && is_pstringrefs p -> Flambda.Prim (Pstringrefu, args, dbg), A.value_unknown Other, (* we improved it, but there is no way to account for that: *) C.Benefit.zero | [Value_string { size; contents = None }; - (Value_int x | Value_constptr x)] + (Value_int x)] when x >= 0 && x < size && is_pbytesrefs p -> Flambda.Prim (Pbytesrefu, args, dbg), A.value_unknown Other, diff --git a/middle_end/printclambda.ml b/middle_end/printclambda.ml index fceb34851d..3b8ffab096 100644 --- a/middle_end/printclambda.ml +++ b/middle_end/printclambda.ml @@ -95,7 +95,6 @@ and uconstant ppf = function fprintf ppf "%S=%a" s structured_constant c | Uconst_ref (s, None) -> fprintf ppf "%S"s | Uconst_int i -> fprintf ppf "%i" i - | Uconst_ptr i -> fprintf ppf "%ia" i and lam ppf = function | Uvar id -> diff --git a/ocamldoc/Makefile.docfiles b/ocamldoc/Makefile.docfiles index fb8c4b3f8c..8cf2fd106a 100644 --- a/ocamldoc/Makefile.docfiles +++ b/ocamldoc/Makefile.docfiles @@ -42,7 +42,7 @@ DOC_COMPILERLIBS_INCLUDES = $(addprefix -I $(SRC)/, $(DOC_COMPILERLIBS_DIRS)) DOC_ALL_INCLUDES = $(DOC_STDLIB_INCLUDES) $(DOC_COMPILERLIBS_INCLUDES) STDLIB_MOD_WP = $(filter-out stdlib__pervasives, $(STDLIB_MODULES)) -STDLIB_MLI0 = $(SRC)/stdlib/pervasives.ml $(STDLIB_MOD_WP:%=$(SRC)/stdlib/%.mli) +STDLIB_MLI0 = $(STDLIB_MOD_WP:%=$(SRC)/stdlib/%.mli) STDLIB_MLIS=\ $(STDLIB_MLI0:$(SRC)/stdlib/stdlib__%=$(SRC)/stdlib/%) \ $(STR_MLIS) \ diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index 8f1fe60002..a035f7852d 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -2394,11 +2394,12 @@ class html = (** A method to create index files. *) method generate_elements_index : 'a. - 'a list -> - ('a -> Odoc_info.Name.t) -> - ('a -> Odoc_info.info option) -> - ('a -> string) -> string -> string -> unit = - fun elements name info target title simple_file -> + ?strip_libname:bool -> + 'a list -> + ('a -> Odoc_info.Name.t) -> + ('a -> Odoc_info.info option) -> + ('a -> string) -> string -> string -> unit = + fun ?(strip_libname=false) elements name info target title simple_file -> try let chanout = open_out (Filename.concat !Global.target_dir simple_file) in let b = new_buf () in @@ -2418,7 +2419,10 @@ class html = let f_ele e = let simple_name = Name.simple (name e) in let father_name = Name.father (name e) in - if father_name = "Stdlib" && father_name <> simple_name then + if strip_libname && + !Odoc_global.library_namespace <> "" && + father_name = !Odoc_global.library_namespace && + father_name <> simple_name then (* avoid duplicata *) () else begin @@ -2839,6 +2843,7 @@ class html = (** Generate the modules index in the file [index_modules.html]. *) method generate_modules_index _module_list = self#generate_elements_index + ~strip_libname:true self#list_modules (fun m -> m.m_name) (fun m -> m.m_info) diff --git a/otherlibs/unix/gettimeofday.c b/otherlibs/unix/gettimeofday.c index 609a9a827e..3e4879cbb8 100644 --- a/otherlibs/unix/gettimeofday.c +++ b/otherlibs/unix/gettimeofday.c @@ -17,22 +17,17 @@ #include <caml/alloc.h> #include <caml/fail.h> #include "unixsupport.h" - -#ifdef HAS_GETTIMEOFDAY - #include <sys/types.h> #include <sys/time.h> -CAMLprim value unix_gettimeofday(value unit) +double unix_gettimeofday_unboxed(value unit) { struct timeval tp; - if (gettimeofday(&tp, NULL) == -1) uerror("gettimeofday", Nothing); - return caml_copy_double((double) tp.tv_sec + (double) tp.tv_usec / 1e6); + gettimeofday(&tp, NULL); + return ((double) tp.tv_sec + (double) tp.tv_usec / 1e6); } -#else - CAMLprim value unix_gettimeofday(value unit) -{ caml_invalid_argument("gettimeofday not implemented"); } - -#endif +{ + return caml_copy_double(unix_gettimeofday_unboxed(unit)); +} diff --git a/otherlibs/unix/time.c b/otherlibs/unix/time.c index f7916c991b..0c2d94ffd1 100644 --- a/otherlibs/unix/time.c +++ b/otherlibs/unix/time.c @@ -18,7 +18,12 @@ #include <caml/alloc.h> #include "unixsupport.h" +double unix_time_unboxed(value unit) +{ + return ((double) time((time_t *) NULL)); +} + CAMLprim value unix_time(value unit) { - return caml_copy_double((double) time((time_t *) NULL)); + return caml_copy_double(unix_time_unboxed(unit)); } diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml index 1d0761516e..4097be0b8a 100644 --- a/otherlibs/unix/unix.ml +++ b/otherlibs/unix/unix.ml @@ -437,8 +437,10 @@ type tm = tm_yday : int; tm_isdst : bool } -external time : unit -> float = "unix_time" -external gettimeofday : unit -> float = "unix_gettimeofday" +external time : unit -> (float [@unboxed]) = + "unix_time" "unix_time_unboxed" [@@noalloc] +external gettimeofday : unit -> (float [@unboxed]) = + "unix_gettimeofday" "unix_gettimeofday_unboxed" [@@noalloc] external gmtime : float -> tm = "unix_gmtime" external localtime : float -> tm = "unix_localtime" external mktime : tm -> float * tm = "unix_mktime" diff --git a/otherlibs/win32unix/gettimeofday.c b/otherlibs/win32unix/gettimeofday.c index 20f62a1f04..6e2b56e8c2 100644 --- a/otherlibs/win32unix/gettimeofday.c +++ b/otherlibs/win32unix/gettimeofday.c @@ -22,7 +22,7 @@ /* Unix epoch as a Windows timestamp in hundreds of ns */ #define epoch_ft 116444736000000000.0; -CAMLprim value unix_gettimeofday(value unit) +double unix_gettimeofday_unboxed(value unit) { FILETIME ft; double tm; @@ -36,5 +36,10 @@ CAMLprim value unix_gettimeofday(value unit) #else tm = *(uint64_t *)&ft - epoch_ft; /* shift to Epoch-relative time */ #endif - return caml_copy_double(tm * 1e-7); /* tm is in 100ns */ + return (tm * 1e-7); /* tm is in 100ns */ +} + +CAMLprim value unix_gettimeofday(value unit) +{ + return caml_copy_double(unix_gettimeofday_unboxed(unit)); } diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml index 8d9865446e..84bd755ec4 100644 --- a/otherlibs/win32unix/unix.ml +++ b/otherlibs/win32unix/unix.ml @@ -566,8 +566,10 @@ type tm = tm_yday : int; tm_isdst : bool } -external time : unit -> float = "unix_time" -external gettimeofday : unit -> float = "unix_gettimeofday" +external time : unit -> (float [@unboxed]) = + "unix_time" "unix_time_unboxed" [@@noalloc] +external gettimeofday : unit -> (float [@unboxed]) = + "unix_gettimeofday" "unix_gettimeofday_unboxed" [@@noalloc] external gmtime : float -> tm = "unix_gmtime" external localtime : float -> tm = "unix_localtime" external mktime : tm -> float * tm = "unix_mktime" diff --git a/runtime/alloc.c b/runtime/alloc.c index 750b5cc51e..28eb7fbe41 100644 --- a/runtime/alloc.c +++ b/runtime/alloc.c @@ -362,3 +362,11 @@ CAMLprim value caml_update_dummy(value dummy, value newval) } return Val_unit; } + +CAMLexport value caml_alloc_some(value v) +{ + CAMLparam1(v); + value some = caml_alloc_small(1, 0); + Store_field(some, 0, v); + CAMLreturn(some); +} diff --git a/runtime/caml/alloc.h b/runtime/caml/alloc.h index 5e96f9ccfd..aaa2e52eee 100644 --- a/runtime/caml/alloc.h +++ b/runtime/caml/alloc.h @@ -61,6 +61,7 @@ CAMLextern value caml_alloc_sprintf(const char * format, ...) __attribute__ ((format (printf, 1, 2))) #endif ; +CAMLextern value caml_alloc_some(value); typedef void (*final_fun)(value); CAMLextern value caml_alloc_final (mlsize_t, /*size in words*/ diff --git a/runtime/caml/mlvalues.h b/runtime/caml/mlvalues.h index 70cb8d9aee..4607321436 100644 --- a/runtime/caml/mlvalues.h +++ b/runtime/caml/mlvalues.h @@ -409,7 +409,13 @@ CAMLextern value caml_atom(tag_t); #define Val_emptylist Val_int(0) #define Tag_cons 0 -CAMLextern value caml_set_oo_id(value obj); +/* Option constructors */ + +#define Val_none Val_int(0) +#define Some_val(v) Field(v, 0) +#define Tag_some 0 +#define Is_none(v) ((v) == Val_None) +#define Is_some(v) Is_block(v) CAMLextern value caml_set_oo_id(value obj); diff --git a/runtime/caml/s.h.in b/runtime/caml/s.h.in index 93edaefc9d..ca55115b82 100644 --- a/runtime/caml/s.h.in +++ b/runtime/caml/s.h.in @@ -192,6 +192,10 @@ /* Define HAS_PUTENV if you have putenv(). */ +#undef HAS_SETENV_UNSETENV + +/* Define HAS_SETENV_UNSETENV if you have setenv() and unsetenv(). */ + #undef HAS_LOCALE_H /* Define HAS_LOCALE_H if you have the include file <locale.h> and the diff --git a/runtime/debugger.c b/runtime/debugger.c index bf936718ca..75574ffb92 100644 --- a/runtime/debugger.c +++ b/runtime/debugger.c @@ -55,6 +55,7 @@ void caml_debugger_cleanup_fork(void) #include <unistd.h> #endif #include <errno.h> +#include <stdlib.h> #include <sys/types.h> #ifndef _WIN32 #include <sys/wait.h> @@ -189,6 +190,15 @@ void caml_debugger_init(void) if (dbg_addr != NULL) caml_stat_free(dbg_addr); dbg_addr = address; + /* #8676: erase the CAML_DEBUG_SOCKET variable so that processes + created by the program being debugged do not try to connect with + the debugger. */ +#if defined(_WIN32) + _wputenv(L"CAML_DEBUG_SOCKET="); +#elif defined(HAS_SETENV_UNSETENV) + unsetenv("CAML_DEBUG_SOCKET"); +#endif + caml_ext_table_init(&breakpoints_table, 16); #ifdef _WIN32 diff --git a/testsuite/tests/basic-modules/anonymous.ocamlc.reference b/testsuite/tests/basic-modules/anonymous.ocamlc.reference index f36800bbf5..22efd590dd 100644 --- a/testsuite/tests/basic-modules/anonymous.ocamlc.reference +++ b/testsuite/tests/basic-modules/anonymous.ocamlc.reference @@ -13,12 +13,11 @@ (apply (field_imm 1 (global CamlinternalMod!)) [0: [0]] B (module-defn(B) Anonymous anonymous.ml(33):703-773 (let (x = [0: "foo" "bar"]) (makeblock 0)))) - (let (f = (function param 0a) s = (makemutable 0 "")) + (let (f = (function param 0) s = (makemutable 0 "")) (seq (ignore (let (*match* = (setfield_ptr 0 s "Hello World!")) (makeblock 0))) (let - (drop = (function param 0a) - *match* = (apply drop (field_mut 0 s))) + (drop = (function param 0) *match* = (apply drop (field_mut 0 s))) (makeblock 0 A B f s drop)))))))) diff --git a/testsuite/tests/basic-modules/anonymous.ocamlopt.flambda.reference b/testsuite/tests/basic-modules/anonymous.ocamlopt.flambda.reference index ad65c73656..c68b4b6bf2 100644 --- a/testsuite/tests/basic-modules/anonymous.ocamlopt.flambda.reference +++ b/testsuite/tests/basic-modules/anonymous.ocamlopt.flambda.reference @@ -12,10 +12,9 @@ (apply (field_imm 1 (global CamlinternalMod!)) [0: [0]] B (module-defn(B) anonymous.ml(33):703-773 (let (x = [0: "foo" "bar"]) (makeblock 0)))) - (let (f = (function param 0a) s = (makemutable 0 "")) + (let (f = (function param 0) s = (makemutable 0 "")) (seq (ignore (let (*match* = (setfield_ptr 0 s "Hello World!")) (makeblock 0))) - (let - (drop = (function param 0a) *match* = (apply drop (field 0 s))) + (let (drop = (function param 0) *match* = (apply drop (field 0 s))) (makeblock 0 A B f s drop))))))) diff --git a/testsuite/tests/basic-modules/anonymous.ocamlopt.reference b/testsuite/tests/basic-modules/anonymous.ocamlopt.reference index 9211fb100f..2bb3dc4a13 100644 --- a/testsuite/tests/basic-modules/anonymous.ocamlopt.reference +++ b/testsuite/tests/basic-modules/anonymous.ocamlopt.reference @@ -12,7 +12,7 @@ (let (x = [0: "foo" "bar"]) (makeblock 0))) (setfield_ptr(root-init) 0 (global Anonymous!) A) (setfield_ptr(root-init) 1 (global Anonymous!) B) - (let (f = (function param 0a)) + (let (f = (function param 0)) (setfield_ptr(root-init) 2 (global Anonymous!) f)) (let (s = (makemutable 0 "")) (setfield_ptr(root-init) 3 (global Anonymous!) s)) @@ -22,11 +22,11 @@ (setfield_ptr 0 (field_imm 3 (global Anonymous!)) "Hello World!")) (makeblock 0))) - (let (drop = (function param 0a)) + (let (drop = (function param 0)) (setfield_ptr(root-init) 4 (global Anonymous!) drop)) (let (*match* = (apply (field_imm 4 (global Anonymous!)) (field_mut 0 (field_imm 3 (global Anonymous!))))) - 0a) - 0a))) + 0) + 0))) diff --git a/testsuite/tests/basic-more/morematch.compilers.reference b/testsuite/tests/basic-more/morematch.compilers.reference index 9404040d6d..2fde3df8e8 100644 --- a/testsuite/tests/basic-more/morematch.compilers.reference +++ b/testsuite/tests/basic-more/morematch.compilers.reference @@ -49,7 +49,7 @@ File "morematch.ml", lines 1050-1053, characters 8-10: 1053 | | C -> 2 Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: -(A `D|B (`B, (`A|`C))) +A `D File "morematch.ml", line 1084, characters 5-51: 1084 | | _, _, _, _, _, A, _, _, _, _, B, _, _, _, _, _ -> "11" ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ diff --git a/testsuite/tests/basic/patmatch_split_no_or.ml b/testsuite/tests/basic/patmatch_split_no_or.ml index eb9312a2c1..9e8e6e4d30 100644 --- a/testsuite/tests/basic/patmatch_split_no_or.ml +++ b/testsuite/tests/basic/patmatch_split_no_or.ml @@ -49,7 +49,7 @@ val last_is_vars : bool * bool -> int = <fun> type t = .. type t += A | B of unit | C of bool * int;; [%%expect{| -0a +0 type t = .. (let (A/25 = (makeblock 248 "A" (caml_fresh_oo_id 0)) diff --git a/testsuite/tests/translprim/comparison_table.compilers.reference b/testsuite/tests/translprim/comparison_table.compilers.reference index 9ed6ba1b42..6a7f46a2f4 100644 --- a/testsuite/tests/translprim/comparison_table.compilers.reference +++ b/testsuite/tests/translprim/comparison_table.compilers.reference @@ -137,14 +137,14 @@ eta_int32_ge = (function prim prim stub (Int32.>= prim prim)) eta_int64_ge = (function prim prim stub (Int64.>= prim prim)) eta_nativeint_ge = (function prim prim stub (Nativeint.>= prim prim)) - int_vec = [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0a]]] - bool_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]] - intlike_vec = [0: [0: 0a 0a] [0: [0: 0a 1a] [0: [0: 1a 0a] 0a]]] - float_vec = [0: [0: 1. 1.] [0: [0: 1. 2.] [0: [0: 2. 1.] 0a]]] - string_vec = [0: [0: "1" "1"] [0: [0: "1" "2"] [0: [0: "2" "1"] 0a]]] - int32_vec = [0: [0: 1l 1l] [0: [0: 1l 2l] [0: [0: 2l 1l] 0a]]] - int64_vec = [0: [0: 1L 1L] [0: [0: 1L 2L] [0: [0: 2L 1L] 0a]]] - nativeint_vec = [0: [0: 1n 1n] [0: [0: 1n 2n] [0: [0: 2n 1n] 0a]]] + int_vec = [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0]]] + bool_vec = [0: [0: 0 0] [0: [0: 0 1] [0: [0: 1 0] 0]]] + intlike_vec = [0: [0: 0 0] [0: [0: 0 1] [0: [0: 1 0] 0]]] + float_vec = [0: [0: 1. 1.] [0: [0: 1. 2.] [0: [0: 2. 1.] 0]]] + string_vec = [0: [0: "1" "1"] [0: [0: "1" "2"] [0: [0: "2" "1"] 0]]] + int32_vec = [0: [0: 1l 1l] [0: [0: 1l 2l] [0: [0: 2l 1l] 0]]] + int64_vec = [0: [0: 1L 1L] [0: [0: 1L 2L] [0: [0: 2L 1L] 0]]] + nativeint_vec = [0: [0: 1n 1n] [0: [0: 1n 2n] [0: [0: 2n 1n] 0]]] test_vec = (function cmp eq ne lt gt le ge vec (let @@ -165,7 +165,7 @@ (makeblock 0 (makeblock 0 gen_lt lt) (makeblock 0 (makeblock 0 gen_gt gt) (makeblock 0 (makeblock 0 gen_le le) - (makeblock 0 (makeblock 0 gen_ge ge) 0a))))))))))) + (makeblock 0 (makeblock 0 gen_ge ge) 0))))))))))) (seq (apply test_vec int_cmp int_eq int_ne int_lt int_gt int_le int_ge int_vec) @@ -205,7 +205,7 @@ (makeblock 0 (makeblock 0 eta_gen_lt lt) (makeblock 0 (makeblock 0 eta_gen_gt gt) (makeblock 0 (makeblock 0 eta_gen_le le) - (makeblock 0 (makeblock 0 eta_gen_ge ge) 0a))))))))))) + (makeblock 0 (makeblock 0 eta_gen_ge ge) 0))))))))))) (seq (apply eta_test_vec eta_int_cmp eta_int_eq eta_int_ne eta_int_lt eta_int_gt eta_int_le eta_int_ge int_vec) diff --git a/testsuite/tests/translprim/ref_spec.compilers.reference b/testsuite/tests/translprim/ref_spec.compilers.reference index 72b48d4f0b..8e27f04bb9 100644 --- a/testsuite/tests/translprim/ref_spec.compilers.reference +++ b/testsuite/tests/translprim/ref_spec.compilers.reference @@ -1,27 +1,27 @@ (setglobal Ref_spec! (let (int_ref = (makemutable 0 (int) 1) - var_ref = (makemutable 0 65a) - vargen_ref = (makemutable 0 65a) - cst_ref = (makemutable 0 0a) - gen_ref = (makemutable 0 0a) + var_ref = (makemutable 0 65) + vargen_ref = (makemutable 0 65) + cst_ref = (makemutable 0 0) + gen_ref = (makemutable 0 0) flt_ref = (makemutable 0 (float) 0.)) - (seq (setfield_imm 0 int_ref 2) (setfield_imm 0 var_ref 66a) - (setfield_ptr 0 vargen_ref [0: 66 0]) (setfield_ptr 0 vargen_ref 67a) - (setfield_imm 0 cst_ref 1a) (setfield_ptr 0 gen_ref [0: "foo"]) - (setfield_ptr 0 gen_ref 0a) (setfield_ptr 0 flt_ref 1.) + (seq (setfield_imm 0 int_ref 2) (setfield_imm 0 var_ref 66) + (setfield_ptr 0 vargen_ref [0: 66 0]) (setfield_ptr 0 vargen_ref 67) + (setfield_imm 0 cst_ref 1) (setfield_ptr 0 gen_ref [0: "foo"]) + (setfield_ptr 0 gen_ref 0) (setfield_ptr 0 flt_ref 1.) (let - (int_rec = (makemutable 0 (*,int) 0a 1) - var_rec = (makemutable 0 0a 65a) - vargen_rec = (makemutable 0 0a 65a) - cst_rec = (makemutable 0 0a 0a) - gen_rec = (makemutable 0 0a 0a) - flt_rec = (makemutable 0 (*,float) 0a 0.) + (int_rec = (makemutable 0 (*,int) 0 1) + var_rec = (makemutable 0 0 65) + vargen_rec = (makemutable 0 0 65) + cst_rec = (makemutable 0 0 0) + gen_rec = (makemutable 0 0 0) + flt_rec = (makemutable 0 (*,float) 0 0.) flt_rec' = (makearray[float] 0. 0.)) - (seq (setfield_imm 1 int_rec 2) (setfield_imm 1 var_rec 66a) + (seq (setfield_imm 1 int_rec 2) (setfield_imm 1 var_rec 66) (setfield_ptr 1 vargen_rec [0: 66 0]) - (setfield_ptr 1 vargen_rec 67a) (setfield_imm 1 cst_rec 1a) - (setfield_ptr 1 gen_rec [0: "foo"]) (setfield_ptr 1 gen_rec 0a) + (setfield_ptr 1 vargen_rec 67) (setfield_imm 1 cst_rec 1) + (setfield_ptr 1 gen_rec [0: "foo"]) (setfield_ptr 1 gen_rec 0) (setfield_ptr 1 flt_rec 1.) (setfloatfield 1 flt_rec' 1.) (let (set_open_poly = (function r y (setfield_ptr 0 r y)) diff --git a/testsuite/tests/typing-gadts/pr5785.ml b/testsuite/tests/typing-gadts/pr5785.ml index 0042083437..a5f2d22439 100644 --- a/testsuite/tests/typing-gadts/pr5785.ml +++ b/testsuite/tests/typing-gadts/pr5785.ml @@ -19,7 +19,7 @@ Lines 7-9, characters 43-24: 9 | | Two, Two -> "four" Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: -(Two, One) +(One, Two) module Add : functor (T : sig type two end) -> sig diff --git a/testsuite/tests/typing-gadts/test.ml b/testsuite/tests/typing-gadts/test.ml index 2738a1ae2f..aa5caf0f43 100644 --- a/testsuite/tests/typing-gadts/test.ml +++ b/testsuite/tests/typing-gadts/test.ml @@ -115,7 +115,7 @@ Lines 24-26, characters 6-30: 26 | | Bar _, Bar _ -> true Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: -(Bar _, Foo _) +(Foo _, Bar _) module Nonexhaustive : sig type 'a u = C1 : int -> int u | C2 : bool -> bool u diff --git a/testsuite/tests/typing-gadts/yallop_bugs.ml b/testsuite/tests/typing-gadts/yallop_bugs.ml index d94e63fde9..7418faae73 100644 --- a/testsuite/tests/typing-gadts/yallop_bugs.ml +++ b/testsuite/tests/typing-gadts/yallop_bugs.ml @@ -62,7 +62,7 @@ Lines 5-7, characters 39-23: 7 | | IntLit , 6 -> false Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: -(IntLit, 0) +(BoolLit, true) val check : 's t * 's -> bool = <fun> |}];; @@ -80,6 +80,6 @@ Lines 3-5, characters 45-38: 5 | | {fst = IntLit ; snd = 6} -> false Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: -{fst=IntLit; snd=0} +{fst=BoolLit; snd=true} val check : ('s t, 's) pair -> bool = <fun> |}];; diff --git a/testsuite/tests/typing-warnings/exhaustiveness.ml b/testsuite/tests/typing-warnings/exhaustiveness.ml index 5099ea844a..a7daad4d11 100644 --- a/testsuite/tests/typing-warnings/exhaustiveness.ml +++ b/testsuite/tests/typing-warnings/exhaustiveness.ml @@ -3,7 +3,6 @@ * expect *) -(* Warn about all relevant cases when possible *) let f = function None, None -> 1 | Some _, Some _ -> 2;; @@ -14,7 +13,7 @@ Lines 1-3, characters 8-23: 3 | | Some _, Some _ -> 2.. Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: -((Some _, None)|(None, Some _)) +(None, Some _) val f : 'a option * 'b option -> int = <fun> |}] @@ -124,7 +123,7 @@ Line 1, characters 8-47: ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 8: this pattern-matching is not exhaustive. Here is an example of a case that is not matched: -({left=Box 0; right=Box 0}|{left=Box 1; right=Box _}) +{left=Box 0; right=Box 0} val f : int box pair -> unit = <fun> |}] diff --git a/testsuite/tests/typing-warnings/fragile_matching.ml b/testsuite/tests/typing-warnings/fragile_matching.ml new file mode 100644 index 0000000000..eef69e0d37 --- /dev/null +++ b/testsuite/tests/typing-warnings/fragile_matching.ml @@ -0,0 +1,108 @@ +(* TEST *) + +(* Tests for stack-overflow crashes caused by a combinatorial + explosition in fragile pattern checking. *) + +[@@@warning "+4"] + +module SyntheticTest = struct + (* from Luc Maranget *) + type t = A | B + + let f = function + | A,A,A,A,A, A,A,A,A,A, A,A,A,A,A, A,A,A -> 1 + | (A|B),(A|B),(A|B),(A|B),(A|B), + (A|B),(A|B),(A|B),(A|B),(A|B), + (A|B),(A|B),(A|B),(A|B),(A|B), + (A|B),(A|B),(A|B) -> 2 +end + +module RealCodeTest = struct + (* from Alex Fedoseev *) + + type visibility = Shown | Hidden + + type ('outputValue, 'message) fieldStatus = + | Pristine + | Dirty of ('outputValue, 'message) result * visibility + + type message = string + + type fieldsStatuses = { + iaasStorageConfigurations : + iaasStorageConfigurationFieldsStatuses array; + } + + and iaasStorageConfigurationFieldsStatuses = { + startDate : (int, message) fieldStatus; + term : (int, message) fieldStatus; + rawStorageCapacity : (int, message) fieldStatus; + diskType : (string option, message) fieldStatus; + connectivityMethod : (string option, message) fieldStatus; + getRequest : (int option, message) fieldStatus; + getRequestUnit : (string option, message) fieldStatus; + putRequest : (int option, message) fieldStatus; + putRequestUnit : (string option, message) fieldStatus; + transferOut : (int option, message) fieldStatus; + transferOutUnit : (string option, message) fieldStatus; + region : (string option, message) fieldStatus; + cloudType : (string option, message) fieldStatus; + description : (string option, message) fieldStatus; + features : (string array, message) fieldStatus; + accessTypes : (string array, message) fieldStatus; + certifications : (string array, message) fieldStatus; + additionalRequirements : (string option, message) fieldStatus; + } + + type interface = { dirty : unit -> bool } + + let useForm () = { + dirty = fun () -> + Array.for_all + (fun item -> + match item with + | { + additionalRequirements = Pristine; + certifications = Pristine; + accessTypes = Pristine; + features = Pristine; + description = Pristine; + cloudType = Pristine; + region = Pristine; + transferOutUnit = Pristine; + transferOut = Pristine; + putRequestUnit = Pristine; + putRequest = Pristine; + getRequestUnit = Pristine; + getRequest = Pristine; + connectivityMethod = Pristine; + diskType = Pristine; + rawStorageCapacity = Pristine; + term = Pristine; + startDate = Pristine; + } -> + false + | { + additionalRequirements = Pristine | Dirty (_, _); + certifications = Pristine | Dirty (_, _); + accessTypes = Pristine | Dirty (_, _); + features = Pristine | Dirty (_, _); + description = Pristine | Dirty (_, _); + cloudType = Pristine | Dirty (_, _); + region = Pristine | Dirty (_, _); + transferOutUnit = Pristine | Dirty (_, _); + transferOut = Pristine | Dirty (_, _); + putRequestUnit = Pristine | Dirty (_, _); + putRequest = Pristine | Dirty (_, _); + getRequestUnit = Pristine | Dirty (_, _); + getRequest = Pristine | Dirty (_, _); + connectivityMethod = Pristine | Dirty (_, _); + diskType = Pristine | Dirty (_, _); + rawStorageCapacity = Pristine | Dirty (_, _); + term = Pristine | Dirty (_, _); + startDate = Pristine | Dirty (_, _); + } -> + true) + [||] + } +end diff --git a/tools/dumpobj.ml b/tools/dumpobj.ml index cc07797768..0efe236bfb 100644 --- a/tools/dumpobj.ml +++ b/tools/dumpobj.ml @@ -92,7 +92,6 @@ let rec print_struct_const = function | Const_base(Const_int32 i) -> printf "%ldl" i | Const_base(Const_nativeint i) -> printf "%ndn" i | Const_base(Const_int64 i) -> printf "%LdL" i - | Const_pointer n -> printf "%da" n | Const_block(tag, args) -> printf "<%d>" tag; begin match args with diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 0d2f0663c9..007698d3ca 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -634,7 +634,13 @@ let build_specialized_submatrices ~extend_row discr rows = (discr, r :: rs) in - (* insert a row of head [p] and rest [r] into the right group *) + (* insert a row of head [p] and rest [r] into the right group + + Note: with this implementation, the order of the groups + is the order of their first row in the source order. + This is a nice property to get exhaustivity counter-examples + in source order. + *) let rec insert_constr head args r = function | [] -> (* if no group matched this row, it has a head constructor that @@ -679,12 +685,15 @@ let build_specialized_submatrices ~extend_row discr rows = in form_groups initial_constr_group [] rows in - { - default = omega_tails; - constrs = - (* insert omega rows in all groups *) - List.fold_right insert_omega omega_tails constr_groups; - } + + (* groups are accumulated in reverse order; + we restore the order of rows in the source code *) + let default = List.rev omega_tails in + let constrs = + List.fold_right insert_omega omega_tails constr_groups + |> List.map (fun (discr, rs) -> (discr, List.rev rs)) + in + { default; constrs; } (* Variant related functions *) @@ -1250,22 +1259,6 @@ let rec do_match pss qs = match qs with (build_specialized_submatrix ~extend_row:(@) q0 pss) (qargs @ qs) - -type 'a exhaust_result = - | No_matching_value - | Witnesses of 'a list - -let rappend r1 r2 = - match r1, r2 with - | No_matching_value, _ -> r2 - | _, No_matching_value -> r1 - | Witnesses l1, Witnesses l2 -> Witnesses (l1 @ l2) - -let rec try_many f = function - | [] -> No_matching_value - | (p,pss)::rest -> - rappend (f (p, pss)) (try_many f rest) - (* let print_pat pat = let rec string_of_pat pat = @@ -1296,14 +1289,14 @@ let print_pat pat = This function should be called for exhaustiveness check only. *) let rec exhaust (ext:Path.t option) pss n = match pss with -| [] -> Witnesses [omegas n] -| []::_ -> No_matching_value +| [] -> Seq.return (omegas n) +| []::_ -> Seq.empty | pss -> let pss = simplify_first_col pss in if not (all_coherent (first_column pss)) then (* We're considering an ill-typed branch, we won't actually be able to produce a well typed value taking that branch. *) - No_matching_value + Seq.empty else begin (* Assuming the first column is ill-typed but considered coherent, we might end up producing an ill-typed witness of non-exhaustivity @@ -1319,61 +1312,53 @@ let rec exhaust (ext:Path.t option) pss n = match pss with match build_specialized_submatrices ~extend_row:(@) q0 pss with | { default; constrs = [] } -> (* first column of pss is made of variables only *) - begin match exhaust ext default (n-1) with - | Witnesses r -> - let q0 = Patterns.Head.to_omega_pattern q0 in - Witnesses (List.map (fun row -> q0::row) r) - | r -> r - end + let sub_witnesses = exhaust ext default (n-1) in + let q0 = Patterns.Head.to_omega_pattern q0 in + Seq.map (fun row -> q0::row) sub_witnesses | { default; constrs } -> let try_non_omega (p,pss) = if is_absent_pat p then - No_matching_value + Seq.empty else - match + let sub_witnesses = exhaust ext pss (List.length (simple_match_args p Patterns.Head.omega []) + n - 1) - with - | Witnesses r -> - let p = Patterns.Head.to_omega_pattern p in - Witnesses (List.map (set_args p) r) - | r -> r in - let before = try_many try_non_omega constrs in - if - full_match false constrs && not (should_extend ext constrs) - then - before - else - let r = exhaust ext default (n-1) in - match r with - | No_matching_value -> before - | Witnesses r -> - try - let p = build_other ext constrs in - let dug = List.map (fun tail -> p :: tail) r in - match before with - | No_matching_value -> Witnesses dug - | Witnesses x -> Witnesses (x @ dug) - with - (* cannot occur, since constructors don't make a full signature *) - | Empty -> fatal_error "Parmatch.exhaust" - end + in + let p = Patterns.Head.to_omega_pattern p in + Seq.map (set_args p) sub_witnesses + in + let try_omega () = + if full_match false constrs && not (should_extend ext constrs) then + Seq.empty + else + let sub_witnesses = exhaust ext default (n-1) in + match build_other ext constrs with + | exception Empty -> + (* cannot occur, since constructors don't make + a full signature *) + fatal_error "Parmatch.exhaust" + | p -> + Seq.map (fun tail -> p :: tail) sub_witnesses + in + (* Lazily compute witnesses for all constructor submatrices + (Some constr_mat) then the default submatrix (None). + Note that the call to [try_omega ()] is delayed to after + all constructor matrices have been traversed. *) + List.map (fun constr_mat -> Some constr_mat) constrs @ [None] + |> List.to_seq + |> Seq.flat_map + (function + | Some constr_mat -> try_non_omega constr_mat + | None -> try_omega ()) + end let exhaust ext pss n = - let ret = exhaust ext pss n in - match ret with - No_matching_value -> No_matching_value - | Witnesses lst -> - let singletons = - List.map - (function - [x] -> x - | _ -> assert false) - lst - in - Witnesses [orify_many singletons] + exhaust ext pss n + |> Seq.map (function + | [x] -> x + | _ -> assert false) (* Another exhaustiveness check, enforcing variant typing. @@ -1931,6 +1916,10 @@ let ppat_of_type env ty = let (ppat, constrs, labels) = Conv.conv (orify_many pats) in PT_pattern (PE_gadt_cases, ppat, constrs, labels) +let typecheck ~pred p = + let (pattern,constrs,labels) = Conv.conv p in + pred constrs labels pattern + let do_check_partial ~pred loc casel pss = match pss with | [] -> (* @@ -1949,48 +1938,34 @@ let do_check_partial ~pred loc casel pss = match pss with end ; Partial | ps::_ -> - begin match exhaust None pss (List.length ps) with - | No_matching_value -> Total - | Witnesses [u] -> - let v = - let (pattern,constrs,labels) = Conv.conv u in - let u' = pred constrs labels pattern in - (* pretty_pat u; - begin match u' with - None -> prerr_endline ": impossible" - | Some _ -> prerr_endline ": possible" - end; *) - u' + let counter_examples = + exhaust None pss (List.length ps) + |> Seq.filter_map (typecheck ~pred) in + match counter_examples () with + | Seq.Nil -> Total + | Seq.Cons (v, _rest) -> + if Warnings.is_active (Warnings.Partial_match "") then begin + let errmsg = + try + let buf = Buffer.create 16 in + let fmt = Format.formatter_of_buffer buf in + Printpat.top_pretty fmt v; + if do_match (initial_only_guarded casel) [v] then + Buffer.add_string buf + "\n(However, some guarded clause may match this value.)"; + if contains_extension v then + Buffer.add_string buf + "\nMatching over values of extensible variant types \ + (the *extension* above)\n\ + must include a wild card pattern in order to be exhaustive." + ; + Buffer.contents buf + with _ -> + "" in - begin match v with - None -> Total - | Some v -> - if Warnings.is_active (Warnings.Partial_match "") then begin - let errmsg = - try - let buf = Buffer.create 16 in - let fmt = Format.formatter_of_buffer buf in - Printpat.top_pretty fmt v; - if do_match (initial_only_guarded casel) [v] then - Buffer.add_string buf - "\n(However, some guarded clause may match this value.)"; - if contains_extension v then - Buffer.add_string buf - "\nMatching over values of extensible variant types \ - (the *extension* above)\n\ - must include a wild card pattern in order to be exhaustive." - ; - Buffer.contents buf - with _ -> - "" - in - Location.prerr_warning loc (Warnings.Partial_match errmsg) - end; - Partial - end - | _ -> - fatal_error "Parmatch.check_partial" - end + Location.prerr_warning loc (Warnings.Partial_match errmsg) + end; + Partial (*****************) (* Fragile check *) @@ -2054,12 +2029,13 @@ let do_check_fragile loc casel pss = | ps::_ -> List.iter (fun ext -> - match exhaust (Some ext) pss (List.length ps) with - | No_matching_value -> + let witnesses = exhaust (Some ext) pss (List.length ps) in + match witnesses () with + | Seq.Nil -> Location.prerr_warning loc (Warnings.Fragile_match (Path.name ext)) - | Witnesses _ -> ()) + | Seq.Cons _ -> ()) exts (********************************) @@ -2075,7 +2051,11 @@ let check_unused pred casel = let qs = [q] in begin try let pss = - get_mins le_pats (List.filter (compats qs) pref) in + (* prev was accumulated in reverse order; + restore source order to get ordered counter-examples *) + List.rev pref + |> List.filter (compats qs) + |> get_mins le_pats in (* First look for redundant or partially redundant patterns *) let r = every_satisfiables (make_rows pss) (make_row qs) in let refute = (c_rhs.exp_desc = Texp_unreachable) in diff --git a/typing/typedecl_separability.ml b/typing/typedecl_separability.ml index f15c2fe361..32e34228a3 100644 --- a/typing/typedecl_separability.ml +++ b/typing/typedecl_separability.ml @@ -658,9 +658,10 @@ let msig_of_context : decl_loc:Location.t -> parameters:type_expr list (** [check_def env def] returns the signature required for the type definition [def] in the typing environment [env]. - The exception [Not_separable] is raised if we discover that - no such signature exists -- the definition will always be invalid. This - only happens when the definition is marked to be unboxed. *) + The exception [Error] is raised if we discover that + no such signature exists -- the definition will always be invalid. + This only happens when the definition is marked to be unboxed. *) + let check_def : Env.t -> type_definition -> Sep.signature = fun env def -> @@ -683,9 +684,29 @@ let check_def ~parameters:constructor.result_type_parameter_instances let compute_decl env decl = - if not Config.flat_float_array then best_msig decl - else check_def env decl - + if Config.flat_float_array then check_def env decl + else + (* Hack: in -no-flat-float-array mode, instead of always returning + [best_msig], we first compute the separability signature -- + falling back to [best_msig] if it fails. + + This discipline is conservative: it never + rejects -no-flat-float-array programs. At the same time it + guarantees that, for any program that is also accepted + in -flat-float-array mode, the same separability will be + inferred in the two modes. In particular, the same .cmi files + and digests will be produced. + + Before we introduced this hack, the production of different + .cmi files would break the build system of the compiler itself, + when trying to build a -no-flat-float-array system from + a bootstrap compiler itself using -flat-float-array. See #9291. + *) + try check_def env decl with + | Error _ -> + (* It could be nice to emit a warning here, so that users know + that their definition would be rejected in -flat-float-array mode *) + best_msig decl (** Separability as a generic property *) type prop = Types.Separability.signature |