From 9e59dbf7304375a0003825646b45d5e0a521195a Mon Sep 17 00:00:00 2001 From: Zesen Qian Date: Wed, 28 Aug 2024 17:39:04 +0100 Subject: [PATCH 01/76] Relax modes for `probe` (#2968) --- ocaml/lambda/translcore.ml | 14 +++++++++----- ocaml/testsuite/tests/typing-modes/probe.ml | 12 ++++++++++++ ocaml/typing/typecore.ml | 2 -- 3 files changed, 21 insertions(+), 7 deletions(-) create mode 100644 ocaml/testsuite/tests/typing-modes/probe.ml diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index 25aff4fcea4..68e97db9cff 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -1116,16 +1116,20 @@ and transl_exp0 ~in_new_scope ~scopes sort e = let assume_zero_alloc = get_assume_zero_alloc ~scopes in let scopes = enter_value_definition ~scopes ~assume_zero_alloc funcid in lfunction - ~kind:(Curried {nlocal=0}) + (* We conservatively assume that all arguments are local. This doesn't + hurt performance as probe handlers are always applied fully. *) + ~kind:(Curried {nlocal=List.length param_idents}) (* CR layouts: Adjust param layouts when we allow other things in probes. *) - ~params:(List.map (fun name -> { name; layout = layout_probe_arg; attributes = Lambda.default_param_attribute; mode = alloc_heap }) param_idents) + ~params:(List.map (fun name -> { name; layout = layout_probe_arg; attributes = Lambda.default_param_attribute; mode = alloc_local }) param_idents) ~return:return_layout - ~body:(maybe_region_layout return_layout body) + ~body:body ~loc:(of_location ~scopes exp.exp_loc) ~attr ~mode:alloc_heap - ~ret_mode:alloc_heap + ~ret_mode:alloc_local + (* CR zqian: the handler function doesn't have a region. However, the + [region] field is currently broken. *) ~region:true in let app = @@ -1133,7 +1137,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e = ap_args = List.map (fun id -> Lvar id) arg_idents; ap_result_layout = return_layout; ap_region_close = Rc_normal; - ap_mode = alloc_heap; + ap_mode = alloc_local; ap_loc = of_location e.exp_loc ~scopes; ap_tailcall = Default_tailcall; ap_inlined = Never_inlined; diff --git a/ocaml/testsuite/tests/typing-modes/probe.ml b/ocaml/testsuite/tests/typing-modes/probe.ml new file mode 100644 index 00000000000..e05201835dd --- /dev/null +++ b/ocaml/testsuite/tests/typing-modes/probe.ml @@ -0,0 +1,12 @@ +(* TEST + flags += "-extension unique"; + expect; +*) + +(* probe can refer to local,nonportable,once values *) + +let f (x @ local nonportable once) = + [%probe "a" (let _ = x in ())] +[%%expect{| +val f : local_ once_ 'a -> unit = +|}] diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index 8bf786eb149..2cdfba372dc 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -6296,8 +6296,6 @@ and type_expect_ | Error () -> raise (Error (loc, env, Probe_format)) | Ok { name; name_loc; enabled_at_init; arg; } -> check_probe_name name name_loc env; - let env = Env.add_escape_lock Probe env in - let env = Env.add_share_lock Probe env in Env.add_probe name; let exp = type_expect env mode_legacy arg (mk_expected Predef.type_unit) in From f6e203f26baf40551d01b7ec55c212aa0fa6cc73 Mon Sep 17 00:00:00 2001 From: Xavier Clerc Date: Fri, 30 Aug 2024 11:23:44 +0200 Subject: [PATCH 02/76] Move selection-related utility functions to a dedicated module (#2999) Move selection-related utility functions to a dedicated module. --- backend/.ocamlformat-enable | 3 +- backend/amd64/selection.ml | 2 +- backend/arm64/selection.ml | 2 +- backend/select_utils.ml | 453 ++++++++++++++++++++++++++++++++++++ backend/select_utils.mli | 171 ++++++++++++++ backend/selectgen.ml | 436 +--------------------------------- backend/selectgen.mli | 98 +++----- dune | 1 + 8 files changed, 665 insertions(+), 501 deletions(-) create mode 100644 backend/select_utils.ml create mode 100644 backend/select_utils.mli diff --git a/backend/.ocamlformat-enable b/backend/.ocamlformat-enable index f1870f702a0..5ce70f4f3ba 100644 --- a/backend/.ocamlformat-enable +++ b/backend/.ocamlformat-enable @@ -1,4 +1,3 @@ - amd64/selection.ml amd64/simd*.ml amd64/stack_check.ml @@ -25,6 +24,8 @@ peephole/**/*.ml peephole/**/*.mli regalloc/**/*.ml regalloc/**/*.mli +select_utils.ml +select_utils.mli selectgen.ml selectgen.mli selection.mli diff --git a/backend/amd64/selection.ml b/backend/amd64/selection.ml index be297eadd33..a1a38306589 100644 --- a/backend/amd64/selection.ml +++ b/backend/amd64/selection.ml @@ -222,7 +222,7 @@ class selector = method! effects_of e = match e with | Cop (Cextcall { func = fn }, args, _) when List.mem fn inline_ops -> - Selectgen.Effect_and_coeffect.join_list_map args self#effects_of + Select_utils.Effect_and_coeffect.join_list_map args self#effects_of | _ -> super#effects_of e method select_addressing _chunk exp = diff --git a/backend/arm64/selection.ml b/backend/arm64/selection.ml index f56aa5bcb41..3f8b6c10402 100644 --- a/backend/arm64/selection.ml +++ b/backend/arm64/selection.ml @@ -89,7 +89,7 @@ class selector = method! effects_of e = match e with | Cop (Cextcall { func }, args, _) when List.mem func inline_ops -> - Selectgen.Effect_and_coeffect.join_list_map args self#effects_of + Select_utils.Effect_and_coeffect.join_list_map args self#effects_of | e -> super#effects_of e method select_addressing chunk = diff --git a/backend/select_utils.ml b/backend/select_utils.ml new file mode 100644 index 00000000000..96c94678983 --- /dev/null +++ b/backend/select_utils.ml @@ -0,0 +1,453 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Selection of pseudo-instructions, assignment of pseudo-registers, + sequentialization. *) + +open Cmm +open Reg +open Mach +module Int = Numbers.Int +module V = Backend_var +module VP = Backend_var.With_provenance + +type trap_stack_info = + | Unreachable + | Reachable of trap_stack + +type static_handler = + { regs : Reg.t array list; + traps_ref : trap_stack_info ref + } + +type environment = + { vars : + (Reg.t array * Backend_var.Provenance.t option * Asttypes.mutable_flag) + V.Map.t; + static_exceptions : static_handler Int.Map.t; + (** Which registers must be populated when jumping to the given + handler. *) + trap_stack : trap_stack + } + +let env_add ?(mut = Asttypes.Immutable) var regs env = + let provenance = VP.provenance var in + let var = VP.var var in + { env with vars = V.Map.add var (regs, provenance, mut) env.vars } + +let env_add_static_exception id v env = + let r = ref Unreachable in + let s : static_handler = { regs = v; traps_ref = r } in + { env with static_exceptions = Int.Map.add id s env.static_exceptions }, r + +let env_find id env = + let regs, _provenance, _mut = V.Map.find id env.vars in + regs + +let env_find_mut id env = + let regs, provenance, mut = V.Map.find id env.vars in + (match mut with + | Asttypes.Mutable -> () + | Asttypes.Immutable -> + Misc.fatal_errorf "Selectgen.env_find_mut: %a is not mutable" V.print id); + regs, provenance + +let _env_find_with_provenance id env = V.Map.find id env.vars + +let env_find_static_exception id env = Int.Map.find id env.static_exceptions + +let env_enter_trywith env id = + let env, _ = env_add_static_exception id [] env in + env + +let env_set_trap_stack env trap_stack = { env with trap_stack } + +let rec combine_traps trap_stack = function + | [] -> trap_stack + | Push t :: l -> combine_traps (Specific_trap (t, trap_stack)) l + | Pop _ :: l -> ( + match trap_stack with + | Uncaught -> Misc.fatal_error "Trying to pop a trap from an empty stack" + | Specific_trap (_, ts) -> combine_traps ts l) + +let print_traps ppf traps = + let rec print_traps ppf = function + | Uncaught -> Format.fprintf ppf "T" + | Specific_trap (lbl, ts) -> Format.fprintf ppf "%d::%a" lbl print_traps ts + in + Format.fprintf ppf "(%a)" print_traps traps + +let set_traps nfail traps_ref base_traps exit_traps = + let traps = combine_traps base_traps exit_traps in + match !traps_ref with + | Unreachable -> + (* Format.eprintf "Traps for %d set to %a@." nfail print_traps traps; *) + traps_ref := Reachable traps + | Reachable prev_traps -> + if prev_traps <> traps + then + Misc.fatal_errorf + "Mismatching trap stacks for continuation %d@.Previous traps: %a@.New \ + traps: %a" + nfail print_traps prev_traps print_traps traps + else () + +let set_traps_for_raise env = + let ts = env.trap_stack in + match ts with + | Uncaught -> () + | Specific_trap (lbl, _) -> ( + match env_find_static_exception lbl env with + | s -> set_traps lbl s.traps_ref ts [Pop lbl] + | exception Not_found -> + Misc.fatal_errorf "Trap %d not registered in env" lbl) + +let trap_stack_is_empty env = + match env.trap_stack with Uncaught -> true | Specific_trap _ -> false + +let pop_all_traps env = + let rec pop_all acc = function + | Uncaught -> acc + | Specific_trap (lbl, t) -> pop_all (Pop lbl :: acc) t + in + pop_all [] env.trap_stack + +let env_empty = + { vars = V.Map.empty; + static_exceptions = Int.Map.empty; + trap_stack = Uncaught + } + +let select_mutable_flag : Asttypes.mutable_flag -> Mach.mutable_flag = function + | Immutable -> Immutable + | Mutable -> Mutable + +(* Infer the type of the result of an operation *) + +let oper_result_type = function + | Capply (ty, _) -> ty + | Cextcall { ty; ty_args = _; alloc = _; func = _ } -> ty + | Cload { memory_chunk } -> ( + match memory_chunk with + | Word_val -> typ_val + | Single { reg = Float64 } | Double -> typ_float + | Single { reg = Float32 } -> typ_float32 + | Onetwentyeight_aligned | Onetwentyeight_unaligned -> typ_vec128 + | _ -> typ_int) + | Calloc _ -> typ_val + | Cstore (_c, _) -> typ_void + | Cdls_get -> typ_val + | Cprefetch _ -> typ_void + | Catomic _ -> typ_int + | Caddi | Csubi | Cmuli | Cmulhi _ | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl + | Clsr | Casr | Cclz _ | Cctz _ | Cpopcnt | Cbswap _ | Ccmpi _ | Ccmpa _ + | Ccmpf _ -> + typ_int + | Caddv -> typ_val + | Cadda -> typ_addr + | Cnegf Float64 + | Cabsf Float64 + | Caddf Float64 + | Csubf Float64 + | Cmulf Float64 + | Cdivf Float64 -> + typ_float + | Cnegf Float32 + | Cabsf Float32 + | Caddf Float32 + | Csubf Float32 + | Cmulf Float32 + | Cdivf Float32 -> + typ_float32 + | Cpackf32 -> typ_float + | Ccsel ty -> ty + | Creinterpret_cast Value_of_int -> typ_val + | Creinterpret_cast V128_of_v128 -> typ_vec128 + | Creinterpret_cast (Float_of_int64 | Float_of_float32) -> typ_float + | Creinterpret_cast (Float32_of_int32 | Float32_of_float) -> typ_float32 + | Creinterpret_cast (Int_of_value | Int64_of_float | Int32_of_float32) -> + typ_int + | Cstatic_cast (Float_of_float32 | Float_of_int Float64) -> typ_float + | Cstatic_cast (Float32_of_float | Float_of_int Float32) -> typ_float32 + | Cstatic_cast (Int_of_float (Float64 | Float32)) -> typ_int + | Cstatic_cast (V128_of_scalar _) -> typ_vec128 + | Cstatic_cast (Scalar_of_v128 Float64x2) -> typ_float + | Cstatic_cast (Scalar_of_v128 Float32x4) -> typ_float32 + | Cstatic_cast (Scalar_of_v128 (Int8x16 | Int16x8 | Int32x4 | Int64x2)) -> + typ_int + | Craise _ -> typ_void + | Cprobe _ -> typ_void + | Cprobe_is_enabled _ -> typ_int + | Copaque -> typ_val + | Cbeginregion -> + (* This must not be typ_val; the begin-region operation returns a naked + pointer into the local allocation stack. *) + typ_int + | Cendregion -> typ_void + | Ctuple_field (field, fields_ty) -> fields_ty.(field) + +(* Infer the size in bytes of the result of an expression whose evaluation may + be deferred (cf. [emit_parts]). *) + +let size_component : machtype_component -> int = function + | Val | Addr -> Arch.size_addr + | Int -> Arch.size_int + | Float -> Arch.size_float + | Float32 -> + (* CR layouts v5.1: reconsider when float32 fields are efficiently packed. + Note that packed float32# arrays are handled via a separate path. *) + Arch.size_float + | Vec128 -> Arch.size_vec128 + +let size_machtype mty = + let size = ref 0 in + for i = 0 to Array.length mty - 1 do + size := !size + size_component mty.(i) + done; + !size + +let size_expr (env : environment) exp = + let rec size localenv = function + | Cconst_int _ | Cconst_natint _ -> Arch.size_int + | Cconst_symbol _ -> Arch.size_addr + | Cconst_float _ -> Arch.size_float + | Cconst_float32 _ -> + (* CR layouts v5.1: reconsider when float32 fields are efficiently packed. + Note that packed float32# arrays are handled via a separate path. *) + Arch.size_float + | Cconst_vec128 _ -> Arch.size_vec128 + | Cvar id -> ( + try V.Map.find id localenv + with Not_found -> ( + try + let regs = env_find id env in + size_machtype (Array.map (fun r -> r.typ) regs) + with Not_found -> + Misc.fatal_error + ("Selection.size_expr: unbound var " ^ V.unique_name id))) + | Ctuple el -> List.fold_right (fun e sz -> size localenv e + sz) el 0 + | Cop (op, _, _) -> size_machtype (oper_result_type op) + | Clet (id, arg, body) -> + size (V.Map.add (VP.var id) (size localenv arg) localenv) body + | Csequence (_e1, e2) -> size localenv e2 + | _ -> Misc.fatal_error "Selection.size_expr" + in + size V.Map.empty exp + +(* Swap the two arguments of an integer comparison *) + +let swap_intcomp = function + | Isigned cmp -> Isigned (swap_integer_comparison cmp) + | Iunsigned cmp -> Iunsigned (swap_integer_comparison cmp) + +(* Naming of registers *) + +let all_regs_anonymous rv = + try + for i = 0 to Array.length rv - 1 do + if not (Reg.anonymous rv.(i)) then raise Exit + done; + true + with Exit -> false + +let name_regs id rv = + let id = VP.var id in + if Array.length rv = 1 + then rv.(0).raw_name <- Raw_name.create_from_var id + else + for i = 0 to Array.length rv - 1 do + rv.(i).raw_name <- Raw_name.create_from_var id; + rv.(i).part <- Some i + done + +let maybe_emit_naming_op env ~bound_name seq regs = + match bound_name with + | None -> () + | Some bound_name -> + let provenance = VP.provenance bound_name in + if Option.is_some provenance + then + let bound_name = VP.var bound_name in + let naming_op = + Iname_for_debugger + { ident = bound_name; + provenance; + which_parameter = None; + is_assignment = false; + regs + } + in + seq#insert_debug env (Iop naming_op) Debuginfo.none [||] [||] + +(* "Join" two instruction sequences, making sure they return their results in + the same registers. *) + +let join env opt_r1 seq1 opt_r2 seq2 ~bound_name = + let maybe_emit_naming_op = maybe_emit_naming_op env ~bound_name in + match opt_r1, opt_r2 with + | None, _ -> opt_r2 + | _, None -> opt_r1 + | Some r1, Some r2 -> + let l1 = Array.length r1 in + assert (l1 = Array.length r2); + let r = Array.make l1 Reg.dummy in + for i = 0 to l1 - 1 do + if Reg.anonymous r1.(i) && Cmm.ge_component r1.(i).typ r2.(i).typ + then ( + r.(i) <- r1.(i); + seq2#insert_move env r2.(i) r1.(i); + maybe_emit_naming_op seq2 [| r1.(i) |]) + else if Reg.anonymous r2.(i) && Cmm.ge_component r2.(i).typ r1.(i).typ + then ( + r.(i) <- r2.(i); + seq1#insert_move env r1.(i) r2.(i); + maybe_emit_naming_op seq1 [| r2.(i) |]) + else + let typ = Cmm.lub_component r1.(i).typ r2.(i).typ in + r.(i) <- Reg.create typ; + seq1#insert_move env r1.(i) r.(i); + maybe_emit_naming_op seq1 [| r.(i) |]; + seq2#insert_move env r2.(i) r.(i); + maybe_emit_naming_op seq2 [| r.(i) |] + done; + Some r + +(* Same, for N branches *) + +let join_array env rs ~bound_name = + let maybe_emit_naming_op = maybe_emit_naming_op env ~bound_name in + let some_res = ref None in + for i = 0 to Array.length rs - 1 do + let r, _ = rs.(i) in + match r with + | None -> () + | Some r -> ( + match !some_res with + | None -> some_res := Some (r, Array.map (fun r -> r.typ) r) + | Some (r', types) -> + let types = + Array.map2 (fun r typ -> Cmm.lub_component r.typ typ) r types + in + some_res := Some (r', types)) + done; + match !some_res with + | None -> None + | Some (template, types) -> + let size_res = Array.length template in + let res = Array.make size_res Reg.dummy in + for i = 0 to size_res - 1 do + res.(i) <- Reg.create types.(i) + done; + for i = 0 to Array.length rs - 1 do + let r, s = rs.(i) in + match r with + | None -> () + | Some r -> + s#insert_moves env r res; + maybe_emit_naming_op s res + done; + Some res + +(* Name of function being compiled *) +let current_function_name = ref "" + +let current_function_is_check_enabled = ref false + +module Effect = struct + type t = + | None + | Raise + | Arbitrary + + let join t1 t2 = + match t1, t2 with + | None, t2 -> t2 + | t1, None -> t1 + | Raise, Raise -> Raise + | Arbitrary, _ | _, Arbitrary -> Arbitrary + + let pure = function None -> true | Raise | Arbitrary -> false +end + +module Coeffect = struct + type t = + | None + | Read_mutable + | Arbitrary + + let join t1 t2 = + match t1, t2 with + | None, t2 -> t2 + | t1, None -> t1 + | Read_mutable, Read_mutable -> Read_mutable + | Arbitrary, _ | _, Arbitrary -> Arbitrary + + let copure = function None -> true | Read_mutable | Arbitrary -> false +end + +module Effect_and_coeffect : sig + type t + + val none : t + + val arbitrary : t + + val effect : t -> Effect.t + + val coeffect : t -> Coeffect.t + + val pure_and_copure : t -> bool + + val effect_only : Effect.t -> t + + val coeffect_only : Coeffect.t -> t + + val create : Effect.t -> Coeffect.t -> t + + val join : t -> t -> t + + val join_list_map : 'a list -> ('a -> t) -> t +end = struct + type t = Effect.t * Coeffect.t + + let none = Effect.None, Coeffect.None + + let arbitrary = Effect.Arbitrary, Coeffect.Arbitrary + + let effect (e, _ce) = e + + let coeffect (_e, ce) = ce + + let pure_and_copure (e, ce) = Effect.pure e && Coeffect.copure ce + + let effect_only e = e, Coeffect.None + + let coeffect_only ce = Effect.None, ce + + let create e ce = e, ce + + let join (e1, ce1) (e2, ce2) = Effect.join e1 e2, Coeffect.join ce1 ce2 + + let join_list_map xs f = + match xs with + | [] -> none + | x :: xs -> List.fold_left (fun acc x -> join acc (f x)) (f x) xs +end + +let select_effects (e : Cmm.effects) : Effect.t = + match e with No_effects -> None | Arbitrary_effects -> Arbitrary + +let select_coeffects (e : Cmm.coeffects) : Coeffect.t = + match e with No_coeffects -> None | Has_coeffects -> Arbitrary diff --git a/backend/select_utils.mli b/backend/select_utils.mli new file mode 100644 index 00000000000..277d33a18bf --- /dev/null +++ b/backend/select_utils.mli @@ -0,0 +1,171 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Selection of pseudo-instructions, assignment of pseudo-registers, + sequentialization. *) + +type trap_stack_info = + | Unreachable + | Reachable of Mach.trap_stack + +type static_handler = + { regs : Reg.t array list; + traps_ref : trap_stack_info ref + } + +type environment = + { vars : + (Reg.t array * Backend_var.Provenance.t option * Asttypes.mutable_flag) + Backend_var.Map.t; + static_exceptions : static_handler Numbers.Int.Map.t; + (** Which registers must be populated when jumping to the given + handler. *) + trap_stack : Mach.trap_stack + } + +val env_add : + ?mut:Asttypes.mutable_flag -> + Backend_var.With_provenance.t -> + Reg.t array -> + environment -> + environment + +val env_add_static_exception : + Lambda.static_label -> + Reg.t array list -> + environment -> + environment * trap_stack_info ref + +val env_find : Backend_var.t -> environment -> Reg.t array + +val env_find_mut : + Backend_var.t -> environment -> Reg.t array * Backend_var.Provenance.t option + +val env_find_static_exception : + Lambda.static_label -> environment -> static_handler + +val env_enter_trywith : environment -> Cmm.trywith_shared_label -> environment + +val env_set_trap_stack : environment -> Mach.trap_stack -> environment + +val set_traps : + Lambda.static_label -> + trap_stack_info ref -> + Mach.trap_stack -> + Cmm.trap_action list -> + unit + +val set_traps_for_raise : environment -> unit + +val trap_stack_is_empty : environment -> bool + +val pop_all_traps : environment -> Cmm.trap_action list + +val env_empty : environment + +val size_component : Cmm.machtype_component -> int + +val size_expr : environment -> Cmm.expression -> int + +val select_mutable_flag : Asttypes.mutable_flag -> Mach.mutable_flag + +val oper_result_type : Cmm.operation -> Cmm.machtype + +val swap_intcomp : Mach.integer_comparison -> Mach.integer_comparison + +val all_regs_anonymous : Reg.t array -> bool + +val name_regs : Backend_var.With_provenance.t -> Reg.t array -> unit + +val join : + 'a -> + Reg.t array option -> + (< insert_debug : + 'a -> + Mach.instruction_desc -> + Debuginfo.t -> + 'c array -> + 'd array -> + unit + ; insert_move : 'a -> Reg.t -> Reg.t -> unit + ; .. > + as + 'b) -> + Reg.t array option -> + 'b -> + bound_name:Backend_var.With_provenance.t option -> + Reg.t array option + +val join_array : + 'a -> + (Reg.t array option + * < insert_debug : + 'a -> + Mach.instruction_desc -> + Debuginfo.t -> + 'b array -> + 'c array -> + unit + ; insert_moves : 'a -> Reg.t array -> Reg.t array -> unit + ; .. >) + array -> + bound_name:Backend_var.With_provenance.t option -> + Reg.t array option + +val current_function_name : string ref + +val current_function_is_check_enabled : bool ref + +module Effect : sig + type t = + | None + | Raise + | Arbitrary +end + +module Coeffect : sig + type t = + | None + | Read_mutable + | Arbitrary +end + +module Effect_and_coeffect : sig + type t + + val none : t + + val arbitrary : t + + val effect : t -> Effect.t + + val coeffect : t -> Coeffect.t + + val pure_and_copure : t -> bool + + val effect_only : Effect.t -> t + + val coeffect_only : Coeffect.t -> t + + val create : Effect.t -> Coeffect.t -> t + + val join : t -> t -> t + + val join_list_map : 'a list -> ('a -> t) -> t +end + +val select_effects : Cmm.effects -> Effect.t + +val select_coeffects : Cmm.coeffects -> Coeffect.t diff --git a/backend/selectgen.ml b/backend/selectgen.ml index e611a11bae4..3743c8b08c9 100644 --- a/backend/selectgen.ml +++ b/backend/selectgen.ml @@ -19,439 +19,11 @@ open Cmm open Reg open Mach +open Select_utils module Int = Numbers.Int module V = Backend_var module VP = Backend_var.With_provenance -type trap_stack_info = - | Unreachable - | Reachable of trap_stack - -type static_handler = - { regs : Reg.t array list; - traps_ref : trap_stack_info ref - } - -type environment = - { vars : - (Reg.t array * Backend_var.Provenance.t option * Asttypes.mutable_flag) - V.Map.t; - static_exceptions : static_handler Int.Map.t; - (** Which registers must be populated when jumping to the given - handler. *) - trap_stack : trap_stack - } - -let env_add ?(mut = Asttypes.Immutable) var regs env = - let provenance = VP.provenance var in - let var = VP.var var in - { env with vars = V.Map.add var (regs, provenance, mut) env.vars } - -let env_add_static_exception id v env = - let r = ref Unreachable in - let s : static_handler = { regs = v; traps_ref = r } in - { env with static_exceptions = Int.Map.add id s env.static_exceptions }, r - -let env_find id env = - let regs, _provenance, _mut = V.Map.find id env.vars in - regs - -let env_find_mut id env = - let regs, provenance, mut = V.Map.find id env.vars in - (match mut with - | Asttypes.Mutable -> () - | Asttypes.Immutable -> - Misc.fatal_errorf "Selectgen.env_find_mut: %a is not mutable" V.print id); - regs, provenance - -let _env_find_with_provenance id env = V.Map.find id env.vars - -let env_find_static_exception id env = Int.Map.find id env.static_exceptions - -let env_enter_trywith env id = - let env, _ = env_add_static_exception id [] env in - env - -let env_set_trap_stack env trap_stack = { env with trap_stack } - -let rec combine_traps trap_stack = function - | [] -> trap_stack - | Push t :: l -> combine_traps (Specific_trap (t, trap_stack)) l - | Pop _ :: l -> ( - match trap_stack with - | Uncaught -> Misc.fatal_error "Trying to pop a trap from an empty stack" - | Specific_trap (_, ts) -> combine_traps ts l) - -let print_traps ppf traps = - let rec print_traps ppf = function - | Uncaught -> Format.fprintf ppf "T" - | Specific_trap (lbl, ts) -> Format.fprintf ppf "%d::%a" lbl print_traps ts - in - Format.fprintf ppf "(%a)" print_traps traps - -let set_traps nfail traps_ref base_traps exit_traps = - let traps = combine_traps base_traps exit_traps in - match !traps_ref with - | Unreachable -> - (* Format.eprintf "Traps for %d set to %a@." nfail print_traps traps; *) - traps_ref := Reachable traps - | Reachable prev_traps -> - if prev_traps <> traps - then - Misc.fatal_errorf - "Mismatching trap stacks for continuation %d@.Previous traps: %a@.New \ - traps: %a" - nfail print_traps prev_traps print_traps traps - else () - -let set_traps_for_raise env = - let ts = env.trap_stack in - match ts with - | Uncaught -> () - | Specific_trap (lbl, _) -> ( - match env_find_static_exception lbl env with - | s -> set_traps lbl s.traps_ref ts [Pop lbl] - | exception Not_found -> - Misc.fatal_errorf "Trap %d not registered in env" lbl) - -let trap_stack_is_empty env = - match env.trap_stack with Uncaught -> true | Specific_trap _ -> false - -let pop_all_traps env = - let rec pop_all acc = function - | Uncaught -> acc - | Specific_trap (lbl, t) -> pop_all (Pop lbl :: acc) t - in - pop_all [] env.trap_stack - -let env_empty = - { vars = V.Map.empty; - static_exceptions = Int.Map.empty; - trap_stack = Uncaught - } - -let select_mutable_flag : Asttypes.mutable_flag -> Mach.mutable_flag = function - | Immutable -> Immutable - | Mutable -> Mutable - -(* Infer the type of the result of an operation *) - -let oper_result_type = function - | Capply (ty, _) -> ty - | Cextcall { ty; ty_args = _; alloc = _; func = _ } -> ty - | Cload { memory_chunk } -> ( - match memory_chunk with - | Word_val -> typ_val - | Single { reg = Float64 } | Double -> typ_float - | Single { reg = Float32 } -> typ_float32 - | Onetwentyeight_aligned | Onetwentyeight_unaligned -> typ_vec128 - | _ -> typ_int) - | Calloc _ -> typ_val - | Cstore (_c, _) -> typ_void - | Cdls_get -> typ_val - | Cprefetch _ -> typ_void - | Catomic _ -> typ_int - | Caddi | Csubi | Cmuli | Cmulhi _ | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl - | Clsr | Casr | Cclz _ | Cctz _ | Cpopcnt | Cbswap _ | Ccmpi _ | Ccmpa _ - | Ccmpf _ -> - typ_int - | Caddv -> typ_val - | Cadda -> typ_addr - | Cnegf Float64 - | Cabsf Float64 - | Caddf Float64 - | Csubf Float64 - | Cmulf Float64 - | Cdivf Float64 -> - typ_float - | Cnegf Float32 - | Cabsf Float32 - | Caddf Float32 - | Csubf Float32 - | Cmulf Float32 - | Cdivf Float32 -> - typ_float32 - | Cpackf32 -> typ_float - | Ccsel ty -> ty - | Creinterpret_cast Value_of_int -> typ_val - | Creinterpret_cast V128_of_v128 -> typ_vec128 - | Creinterpret_cast (Float_of_int64 | Float_of_float32) -> typ_float - | Creinterpret_cast (Float32_of_int32 | Float32_of_float) -> typ_float32 - | Creinterpret_cast (Int_of_value | Int64_of_float | Int32_of_float32) -> - typ_int - | Cstatic_cast (Float_of_float32 | Float_of_int Float64) -> typ_float - | Cstatic_cast (Float32_of_float | Float_of_int Float32) -> typ_float32 - | Cstatic_cast (Int_of_float (Float64 | Float32)) -> typ_int - | Cstatic_cast (V128_of_scalar _) -> typ_vec128 - | Cstatic_cast (Scalar_of_v128 Float64x2) -> typ_float - | Cstatic_cast (Scalar_of_v128 Float32x4) -> typ_float32 - | Cstatic_cast (Scalar_of_v128 (Int8x16 | Int16x8 | Int32x4 | Int64x2)) -> - typ_int - | Craise _ -> typ_void - | Cprobe _ -> typ_void - | Cprobe_is_enabled _ -> typ_int - | Copaque -> typ_val - | Cbeginregion -> - (* This must not be typ_val; the begin-region operation returns a naked - pointer into the local allocation stack. *) - typ_int - | Cendregion -> typ_void - | Ctuple_field (field, fields_ty) -> fields_ty.(field) - -(* Infer the size in bytes of the result of an expression whose evaluation may - be deferred (cf. [emit_parts]). *) - -let size_component : machtype_component -> int = function - | Val | Addr -> Arch.size_addr - | Int -> Arch.size_int - | Float -> Arch.size_float - | Float32 -> - (* CR layouts v5.1: reconsider when float32 fields are efficiently packed. - Note that packed float32# arrays are handled via a separate path. *) - Arch.size_float - | Vec128 -> Arch.size_vec128 - -let size_machtype mty = - let size = ref 0 in - for i = 0 to Array.length mty - 1 do - size := !size + size_component mty.(i) - done; - !size - -let size_expr (env : environment) exp = - let rec size localenv = function - | Cconst_int _ | Cconst_natint _ -> Arch.size_int - | Cconst_symbol _ -> Arch.size_addr - | Cconst_float _ -> Arch.size_float - | Cconst_float32 _ -> - (* CR layouts v5.1: reconsider when float32 fields are efficiently packed. - Note that packed float32# arrays are handled via a separate path. *) - Arch.size_float - | Cconst_vec128 _ -> Arch.size_vec128 - | Cvar id -> ( - try V.Map.find id localenv - with Not_found -> ( - try - let regs = env_find id env in - size_machtype (Array.map (fun r -> r.typ) regs) - with Not_found -> - Misc.fatal_error - ("Selection.size_expr: unbound var " ^ V.unique_name id))) - | Ctuple el -> List.fold_right (fun e sz -> size localenv e + sz) el 0 - | Cop (op, _, _) -> size_machtype (oper_result_type op) - | Clet (id, arg, body) -> - size (V.Map.add (VP.var id) (size localenv arg) localenv) body - | Csequence (_e1, e2) -> size localenv e2 - | _ -> Misc.fatal_error "Selection.size_expr" - in - size V.Map.empty exp - -(* Swap the two arguments of an integer comparison *) - -let swap_intcomp = function - | Isigned cmp -> Isigned (swap_integer_comparison cmp) - | Iunsigned cmp -> Iunsigned (swap_integer_comparison cmp) - -(* Naming of registers *) - -let all_regs_anonymous rv = - try - for i = 0 to Array.length rv - 1 do - if not (Reg.anonymous rv.(i)) then raise Exit - done; - true - with Exit -> false - -let name_regs id rv = - let id = VP.var id in - if Array.length rv = 1 - then rv.(0).raw_name <- Raw_name.create_from_var id - else - for i = 0 to Array.length rv - 1 do - rv.(i).raw_name <- Raw_name.create_from_var id; - rv.(i).part <- Some i - done - -let maybe_emit_naming_op env ~bound_name seq regs = - match bound_name with - | None -> () - | Some bound_name -> - let provenance = VP.provenance bound_name in - if Option.is_some provenance - then - let bound_name = VP.var bound_name in - let naming_op = - Iname_for_debugger - { ident = bound_name; - provenance; - which_parameter = None; - is_assignment = false; - regs - } - in - seq#insert_debug env (Iop naming_op) Debuginfo.none [||] [||] - -(* "Join" two instruction sequences, making sure they return their results in - the same registers. *) - -let join env opt_r1 seq1 opt_r2 seq2 ~bound_name = - let maybe_emit_naming_op = maybe_emit_naming_op env ~bound_name in - match opt_r1, opt_r2 with - | None, _ -> opt_r2 - | _, None -> opt_r1 - | Some r1, Some r2 -> - let l1 = Array.length r1 in - assert (l1 = Array.length r2); - let r = Array.make l1 Reg.dummy in - for i = 0 to l1 - 1 do - if Reg.anonymous r1.(i) && Cmm.ge_component r1.(i).typ r2.(i).typ - then ( - r.(i) <- r1.(i); - seq2#insert_move env r2.(i) r1.(i); - maybe_emit_naming_op seq2 [| r1.(i) |]) - else if Reg.anonymous r2.(i) && Cmm.ge_component r2.(i).typ r1.(i).typ - then ( - r.(i) <- r2.(i); - seq1#insert_move env r1.(i) r2.(i); - maybe_emit_naming_op seq1 [| r2.(i) |]) - else - let typ = Cmm.lub_component r1.(i).typ r2.(i).typ in - r.(i) <- Reg.create typ; - seq1#insert_move env r1.(i) r.(i); - maybe_emit_naming_op seq1 [| r.(i) |]; - seq2#insert_move env r2.(i) r.(i); - maybe_emit_naming_op seq2 [| r.(i) |] - done; - Some r - -(* Same, for N branches *) - -let join_array env rs ~bound_name = - let maybe_emit_naming_op = maybe_emit_naming_op env ~bound_name in - let some_res = ref None in - for i = 0 to Array.length rs - 1 do - let r, _ = rs.(i) in - match r with - | None -> () - | Some r -> ( - match !some_res with - | None -> some_res := Some (r, Array.map (fun r -> r.typ) r) - | Some (r', types) -> - let types = - Array.map2 (fun r typ -> Cmm.lub_component r.typ typ) r types - in - some_res := Some (r', types)) - done; - match !some_res with - | None -> None - | Some (template, types) -> - let size_res = Array.length template in - let res = Array.make size_res Reg.dummy in - for i = 0 to size_res - 1 do - res.(i) <- Reg.create types.(i) - done; - for i = 0 to Array.length rs - 1 do - let r, s = rs.(i) in - match r with - | None -> () - | Some r -> - s#insert_moves env r res; - maybe_emit_naming_op s res - done; - Some res - -(* Name of function being compiled *) -let current_function_name = ref "" - -let current_function_is_check_enabled = ref false - -module Effect = struct - type t = - | None - | Raise - | Arbitrary - - let join t1 t2 = - match t1, t2 with - | None, t2 -> t2 - | t1, None -> t1 - | Raise, Raise -> Raise - | Arbitrary, _ | _, Arbitrary -> Arbitrary - - let pure = function None -> true | Raise | Arbitrary -> false -end - -module Coeffect = struct - type t = - | None - | Read_mutable - | Arbitrary - - let join t1 t2 = - match t1, t2 with - | None, t2 -> t2 - | t1, None -> t1 - | Read_mutable, Read_mutable -> Read_mutable - | Arbitrary, _ | _, Arbitrary -> Arbitrary - - let copure = function None -> true | Read_mutable | Arbitrary -> false -end - -module Effect_and_coeffect : sig - type t - - val none : t - - val arbitrary : t - - val effect : t -> Effect.t - - val coeffect : t -> Coeffect.t - - val pure_and_copure : t -> bool - - val effect_only : Effect.t -> t - - val coeffect_only : Coeffect.t -> t - - val create : Effect.t -> Coeffect.t -> t - - val join : t -> t -> t - - val join_list_map : 'a list -> ('a -> t) -> t -end = struct - type t = Effect.t * Coeffect.t - - let none = Effect.None, Coeffect.None - - let arbitrary = Effect.Arbitrary, Coeffect.Arbitrary - - let effect (e, _ce) = e - - let coeffect (_e, ce) = ce - - let pure_and_copure (e, ce) = Effect.pure e && Coeffect.copure ce - - let effect_only e = e, Coeffect.None - - let coeffect_only ce = Effect.None, ce - - let create e ce = e, ce - - let join (e1, ce1) (e2, ce2) = Effect.join e1 e2, Coeffect.join ce1 ce2 - - let join_list_map xs f = - match xs with - | [] -> none - | x :: xs -> List.fold_left (fun acc x -> join acc (f x)) (f x) xs -end - -let select_effects (e : Cmm.effects) : Effect.t = - match e with No_effects -> None | Arbitrary_effects -> Arbitrary - -let select_coeffects (e : Cmm.coeffects) : Coeffect.t = - match e with No_coeffects -> None | Has_coeffects -> Arbitrary - (* The default instruction selection class *) class virtual selector_generic = @@ -511,7 +83,7 @@ class virtual selector_generic = the block is allocated, then the remaining arguments are evaluated before being combined with the temporaries. *) method effects_of exp = - let module EC = Effect_and_coeffect in + let module EC = Select_utils.Effect_and_coeffect in match exp with | Cconst_int _ | Cconst_natint _ | Cconst_float32 _ | Cconst_float _ | Cconst_symbol _ | Cconst_vec128 _ | Cvar _ -> @@ -1317,7 +889,7 @@ class virtual selector_generic = (and to be consistent with the bytecode compiler). *) method private emit_parts (env : environment) ~effects_after exp = - let module EC = Effect_and_coeffect in + let module EC = Select_utils.Effect_and_coeffect in let may_defer_evaluation = let ec = self#effects_of exp in match EC.effect ec with @@ -1376,7 +948,7 @@ class virtual selector_generic = Some (Cvar id, env_add (VP.create id) tmp env) method private emit_parts_list (env : environment) exp_list = - let module EC = Effect_and_coeffect in + let module EC = Select_utils.Effect_and_coeffect in let exp_list_right_to_left, _effect = (* Annotate each expression with the (co)effects that happen after it when the original expression list is evaluated from right to left. diff --git a/backend/selectgen.mli b/backend/selectgen.mli index 419105c4296..481646ab81b 100644 --- a/backend/selectgen.mli +++ b/backend/selectgen.mli @@ -16,57 +16,6 @@ (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) -type environment - -val env_add : - ?mut:Asttypes.mutable_flag -> - Backend_var.With_provenance.t -> - Reg.t array -> - environment -> - environment - -val env_find : Backend_var.t -> environment -> Reg.t array - -val size_expr : environment -> Cmm.expression -> int - -val select_mutable_flag : Asttypes.mutable_flag -> Mach.mutable_flag - -module Effect : sig - type t = - | None - | Raise - | Arbitrary -end - -module Coeffect : sig - type t = - | None - | Read_mutable - | Arbitrary -end - -module Effect_and_coeffect : sig - type t - - val none : t - - val arbitrary : t - - val effect : t -> Effect.t - - val coeffect : t -> Coeffect.t - - val effect_only : Effect.t -> t - - val coeffect_only : Coeffect.t -> t - - val create : Effect.t -> Coeffect.t -> t - - val join : t -> t -> t - - val join_list_map : 'a list -> ('a -> t) -> t -end - class virtual selector_generic : object (* The following methods must or can be overridden by the processor @@ -89,7 +38,7 @@ class virtual selector_generic : method is_simple_expr : Cmm.expression -> bool - method effects_of : Cmm.expression -> Effect_and_coeffect.t + method effects_of : Cmm.expression -> Select_utils.Effect_and_coeffect.t (* Can be overridden to reflect special extcalls known to be pure *) method select_operation : @@ -115,12 +64,16 @@ class virtual selector_generic : stored as pairs of integer registers. *) method insert_op : - environment -> Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array + Select_utils.environment -> + Mach.operation -> + Reg.t array -> + Reg.t array -> + Reg.t array (* Can be overridden to deal with 2-address instructions or instructions with hardwired input/output registers *) method insert_op_debug : - environment -> + Select_utils.environment -> Mach.operation -> Debuginfo.t -> Reg.t array -> @@ -130,20 +83,28 @@ class virtual selector_generic : with hardwired input/output registers *) method insert_move_extcall_arg : - environment -> Cmm.exttype -> Reg.t array -> Reg.t array -> unit + Select_utils.environment -> + Cmm.exttype -> + Reg.t array -> + Reg.t array -> + unit (* Can be overridden to deal with unusual unboxed calling conventions, e.g. on a 64-bit platform, passing unboxed 32-bit arguments in 32-bit stack slots. *) method emit_extcall_args : - environment -> + Select_utils.environment -> Cmm.exttype list -> Cmm.expression list -> Reg.t array * int (* Can be overridden to deal with stack-based calling conventions *) method emit_stores : - environment -> Debuginfo.t -> Cmm.expression list -> Reg.t array -> unit + Select_utils.environment -> + Debuginfo.t -> + Cmm.expression list -> + Reg.t array -> + unit (* Fill a freshly allocated block. Can be overridden for architectures that do not provide Arch.offset_addressing. *) @@ -183,39 +144,44 @@ class virtual selector_generic : method extract : Mach.instruction method insert : - environment -> Mach.instruction_desc -> Reg.t array -> Reg.t array -> unit + Select_utils.environment -> + Mach.instruction_desc -> + Reg.t array -> + Reg.t array -> + unit method insert_debug : - environment -> + Select_utils.environment -> Mach.instruction_desc -> Debuginfo.t -> Reg.t array -> Reg.t array -> unit - method insert_move : environment -> Reg.t -> Reg.t -> unit + method insert_move : Select_utils.environment -> Reg.t -> Reg.t -> unit method insert_move_args : - environment -> Reg.t array -> Reg.t array -> int -> unit + Select_utils.environment -> Reg.t array -> Reg.t array -> int -> unit method insert_move_results : - environment -> Reg.t array -> Reg.t array -> int -> unit + Select_utils.environment -> Reg.t array -> Reg.t array -> int -> unit - method insert_moves : environment -> Reg.t array -> Reg.t array -> unit + method insert_moves : + Select_utils.environment -> Reg.t array -> Reg.t array -> unit method emit_expr : - environment -> + Select_utils.environment -> Cmm.expression -> bound_name:Backend_var.With_provenance.t option -> Reg.t array option method emit_expr_aux : - environment -> + Select_utils.environment -> Cmm.expression -> bound_name:Backend_var.With_provenance.t option -> Reg.t array option - method emit_tail : environment -> Cmm.expression -> unit + method emit_tail : Select_utils.environment -> Cmm.expression -> unit (* [contains_calls] is declared as a reference instance variable, instead of a mutable boolean instance variable, because the traversal uses diff --git a/dune b/dune index 9a833d91812..788de1da444 100755 --- a/dune +++ b/dune @@ -134,6 +134,7 @@ relocation_entry relocation_table section_table + select_utils selectgen selection spill From e4821c29e9a62a5059d0f26f83eeb4de4af3fc7b Mon Sep 17 00:00:00 2001 From: Xavier Clerc Date: Fri, 30 Aug 2024 12:57:02 +0200 Subject: [PATCH 03/76] Selection: enable warnings and remove `open`s (#3000) --- backend/amd64/selection.ml | 21 +- backend/arm64/selection.ml | 1 - backend/select_utils.ml | 48 ++--- backend/select_utils.mli | 2 + backend/selectgen.ml | 398 ++++++++++++++++++++----------------- backend/selectgen.mli | 2 + 6 files changed, 256 insertions(+), 216 deletions(-) diff --git a/backend/amd64/selection.ml b/backend/amd64/selection.ml index a1a38306589..437cc2ef0c8 100644 --- a/backend/amd64/selection.ml +++ b/backend/amd64/selection.ml @@ -18,7 +18,6 @@ open Arch open Proc open Cmm -open Mach (* Auxiliary for recognizing addressing modes *) @@ -89,7 +88,7 @@ let rdx = phys_reg Int 4 let _xmm0v () = phys_reg Vec128 100 let pseudoregs_for_operation op arg res = - match op with + match (op : Mach.operation) with (* Two-address binary operations: arg.(0) and res.(0) must be the same *) | Iintop (Iadd | Isub | Imul | Iand | Ior | Ixor) | Ifloatop ((Float32 | Float64), (Iaddf | Isubf | Imulf | Idivf)) -> @@ -279,10 +278,14 @@ class selector = arg ) -> Ispecific (Ilea addr), [arg]) (* Recognize float arithmetic with memory. *) - | Caddf width -> self#select_floatarith true width Iaddf Ifloatadd args - | Csubf width -> self#select_floatarith false width Isubf Ifloatsub args - | Cmulf width -> self#select_floatarith true width Imulf Ifloatmul args - | Cdivf width -> self#select_floatarith false width Idivf Ifloatdiv args + | Caddf width -> + self#select_floatarith true width Mach.Iaddf Arch.Ifloatadd args + | Csubf width -> + self#select_floatarith false width Mach.Isubf Arch.Ifloatsub args + | Cmulf width -> + self#select_floatarith true width Mach.Imulf Arch.Ifloatmul args + | Cdivf width -> + self#select_floatarith false width Mach.Idivf Arch.Ifloatdiv args | Cpackf32 -> (* We must operate on registers. This is because if the second argument was a float stack slot, the resulting UNPCKLPS instruction would @@ -377,7 +380,7 @@ class selector = [loc2], _ ) ] ) -> let addr, arg2 = self#select_addressing chunk loc2 in - Ispecific (Ifloatarithmem (width, mem_op, addr)), [arg1; arg2] + Mach.Ispecific (Ifloatarithmem (width, mem_op, addr)), [arg1; arg2] | ( Float64, [Cop (Cload { memory_chunk = Double as chunk; _ }, [loc1], _); arg2] ) | ( Float32, @@ -388,8 +391,8 @@ class selector = arg2 ] ) when commutative -> let addr, arg1 = self#select_addressing chunk loc1 in - Ispecific (Ifloatarithmem (width, mem_op, addr)), [arg2; arg1] - | _, [arg1; arg2] -> Ifloatop (width, regular_op), [arg1; arg2] + Mach.Ispecific (Ifloatarithmem (width, mem_op, addr)), [arg2; arg1] + | _, [arg1; arg2] -> Mach.Ifloatop (width, regular_op), [arg1; arg2] | _ -> assert false method! mark_c_tailcall = contains_calls := true diff --git a/backend/arm64/selection.ml b/backend/arm64/selection.ml index 3f8b6c10402..76cc5157ecc 100644 --- a/backend/arm64/selection.ml +++ b/backend/arm64/selection.ml @@ -19,7 +19,6 @@ open Arch open Cmm -open Mach let is_offset chunk n = (n >= -256 && n <= 255) (* 9 bits signed unscaled *) diff --git a/backend/select_utils.ml b/backend/select_utils.ml index 96c94678983..55bfd1ca73c 100644 --- a/backend/select_utils.ml +++ b/backend/select_utils.ml @@ -16,16 +16,16 @@ (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) +[@@@ocaml.warning "+a-4-9-40-41-42"] + open Cmm -open Reg -open Mach module Int = Numbers.Int module V = Backend_var module VP = Backend_var.With_provenance type trap_stack_info = | Unreachable - | Reachable of trap_stack + | Reachable of Mach.trap_stack type static_handler = { regs : Reg.t array list; @@ -39,7 +39,7 @@ type environment = static_exceptions : static_handler Int.Map.t; (** Which registers must be populated when jumping to the given handler. *) - trap_stack : trap_stack + trap_stack : Mach.trap_stack } let env_add ?(mut = Asttypes.Immutable) var regs env = @@ -76,16 +76,17 @@ let env_set_trap_stack env trap_stack = { env with trap_stack } let rec combine_traps trap_stack = function | [] -> trap_stack - | Push t :: l -> combine_traps (Specific_trap (t, trap_stack)) l + | Push t :: l -> combine_traps (Mach.Specific_trap (t, trap_stack)) l | Pop _ :: l -> ( - match trap_stack with + match (trap_stack : Mach.trap_stack) with | Uncaught -> Misc.fatal_error "Trying to pop a trap from an empty stack" | Specific_trap (_, ts) -> combine_traps ts l) let print_traps ppf traps = let rec print_traps ppf = function - | Uncaught -> Format.fprintf ppf "T" - | Specific_trap (lbl, ts) -> Format.fprintf ppf "%d::%a" lbl print_traps ts + | Mach.Uncaught -> Format.fprintf ppf "T" + | Mach.Specific_trap (lbl, ts) -> + Format.fprintf ppf "%d::%a" lbl print_traps ts in Format.fprintf ppf "(%a)" print_traps traps @@ -119,8 +120,8 @@ let trap_stack_is_empty env = let pop_all_traps env = let rec pop_all acc = function - | Uncaught -> acc - | Specific_trap (lbl, t) -> pop_all (Pop lbl :: acc) t + | Mach.Uncaught -> acc + | Mach.Specific_trap (lbl, t) -> pop_all (Pop lbl :: acc) t in pop_all [] env.trap_stack @@ -233,7 +234,7 @@ let size_expr (env : environment) exp = with Not_found -> ( try let regs = env_find id env in - size_machtype (Array.map (fun r -> r.typ) regs) + size_machtype (Array.map (fun r -> r.Reg.typ) regs) with Not_found -> Misc.fatal_error ("Selection.size_expr: unbound var " ^ V.unique_name id))) @@ -249,8 +250,8 @@ let size_expr (env : environment) exp = (* Swap the two arguments of an integer comparison *) let swap_intcomp = function - | Isigned cmp -> Isigned (swap_integer_comparison cmp) - | Iunsigned cmp -> Iunsigned (swap_integer_comparison cmp) + | Mach.Isigned cmp -> Mach.Isigned (swap_integer_comparison cmp) + | Mach.Iunsigned cmp -> Mach.Iunsigned (swap_integer_comparison cmp) (* Naming of registers *) @@ -265,11 +266,11 @@ let all_regs_anonymous rv = let name_regs id rv = let id = VP.var id in if Array.length rv = 1 - then rv.(0).raw_name <- Raw_name.create_from_var id + then rv.(0).Reg.raw_name <- Reg.Raw_name.create_from_var id else for i = 0 to Array.length rv - 1 do - rv.(i).raw_name <- Raw_name.create_from_var id; - rv.(i).part <- Some i + rv.(i).Reg.raw_name <- Reg.Raw_name.create_from_var id; + rv.(i).Reg.part <- Some i done let maybe_emit_naming_op env ~bound_name seq regs = @@ -281,7 +282,7 @@ let maybe_emit_naming_op env ~bound_name seq regs = then let bound_name = VP.var bound_name in let naming_op = - Iname_for_debugger + Mach.Iname_for_debugger { ident = bound_name; provenance; which_parameter = None; @@ -289,7 +290,7 @@ let maybe_emit_naming_op env ~bound_name seq regs = regs } in - seq#insert_debug env (Iop naming_op) Debuginfo.none [||] [||] + seq#insert_debug env (Mach.Iop naming_op) Debuginfo.none [||] [||] (* "Join" two instruction sequences, making sure they return their results in the same registers. *) @@ -304,18 +305,19 @@ let join env opt_r1 seq1 opt_r2 seq2 ~bound_name = assert (l1 = Array.length r2); let r = Array.make l1 Reg.dummy in for i = 0 to l1 - 1 do - if Reg.anonymous r1.(i) && Cmm.ge_component r1.(i).typ r2.(i).typ + if Reg.anonymous r1.(i) && Cmm.ge_component r1.(i).Reg.typ r2.(i).Reg.typ then ( r.(i) <- r1.(i); seq2#insert_move env r2.(i) r1.(i); maybe_emit_naming_op seq2 [| r1.(i) |]) - else if Reg.anonymous r2.(i) && Cmm.ge_component r2.(i).typ r1.(i).typ + else if Reg.anonymous r2.(i) + && Cmm.ge_component r2.(i).Reg.typ r1.(i).Reg.typ then ( r.(i) <- r2.(i); seq1#insert_move env r1.(i) r2.(i); maybe_emit_naming_op seq1 [| r2.(i) |]) else - let typ = Cmm.lub_component r1.(i).typ r2.(i).typ in + let typ = Cmm.lub_component r1.(i).Reg.typ r2.(i).Reg.typ in r.(i) <- Reg.create typ; seq1#insert_move env r1.(i) r.(i); maybe_emit_naming_op seq1 [| r.(i) |]; @@ -335,10 +337,10 @@ let join_array env rs ~bound_name = | None -> () | Some r -> ( match !some_res with - | None -> some_res := Some (r, Array.map (fun r -> r.typ) r) + | None -> some_res := Some (r, Array.map (fun r -> r.Reg.typ) r) | Some (r', types) -> let types = - Array.map2 (fun r typ -> Cmm.lub_component r.typ typ) r types + Array.map2 (fun r typ -> Cmm.lub_component r.Reg.typ typ) r types in some_res := Some (r', types)) done; diff --git a/backend/select_utils.mli b/backend/select_utils.mli index 277d33a18bf..f1421040a8d 100644 --- a/backend/select_utils.mli +++ b/backend/select_utils.mli @@ -16,6 +16,8 @@ (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) +[@@@ocaml.warning "+a-4-9-40-41-42"] + type trap_stack_info = | Unreachable | Reachable of Mach.trap_stack diff --git a/backend/selectgen.ml b/backend/selectgen.ml index 3743c8b08c9..bf8ebe2bb4c 100644 --- a/backend/selectgen.ml +++ b/backend/selectgen.ml @@ -16,16 +16,17 @@ (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) +[@@@ocaml.warning "+a-4-9-40-41-42"] + open Cmm -open Reg -open Mach -open Select_utils module Int = Numbers.Int module V = Backend_var module VP = Backend_var.With_provenance (* The default instruction selection class *) +type environment = Select_utils.environment + class virtual selector_generic = object (self : 'self) (* A syntactic criterion used in addition to judgements about (co)effects as @@ -100,19 +101,23 @@ class virtual selector_generic = let from_op = match op with | Cextcall { effects = e; coeffects = ce } -> - EC.create (select_effects e) (select_coeffects ce) + EC.create + (Select_utils.select_effects e) + (Select_utils.select_coeffects ce) | Capply _ | Cprobe _ | Copaque -> EC.arbitrary | Calloc Alloc_heap -> EC.none - | Calloc Alloc_local -> EC.coeffect_only Coeffect.Arbitrary - | Cstore _ -> EC.effect_only Effect.Arbitrary + | Calloc Alloc_local -> + EC.coeffect_only Select_utils.Coeffect.Arbitrary + | Cstore _ -> EC.effect_only Select_utils.Effect.Arbitrary | Cbeginregion | Cendregion -> EC.arbitrary | Cprefetch _ -> EC.arbitrary | Catomic _ -> EC.arbitrary - | Craise _ -> EC.effect_only Effect.Raise + | Craise _ -> EC.effect_only Select_utils.Effect.Raise | Cload { mutability = Asttypes.Immutable } -> EC.none | Cload { mutability = Asttypes.Mutable } | Cdls_get -> - EC.coeffect_only Coeffect.Read_mutable - | Cprobe_is_enabled _ -> EC.coeffect_only Coeffect.Arbitrary + EC.coeffect_only Select_utils.Coeffect.Read_mutable + | Cprobe_is_enabled _ -> + EC.coeffect_only Select_utils.Coeffect.Arbitrary | Ctuple_field _ | Caddi | Csubi | Cmuli | Cmulhi _ | Cdivi | Cmodi | Cand | Cor | Cxor | Cbswap _ | Ccsel _ | Cclz _ | Cctz _ | Cpopcnt | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ | Cnegf _ @@ -126,7 +131,7 @@ class virtual selector_generic = (* Says whether an integer constant is a suitable immediate argument for the given integer operation *) - method is_immediate op n = + method is_immediate (op : Mach.integer_operation) n = match op with | Ilsl | Ilsr | Iasr -> n >= 0 && n < Arch.size_int * 8 | _ -> false @@ -134,7 +139,7 @@ class virtual selector_generic = (* Says whether an integer constant is a suitable immediate argument for the given integer test *) - method virtual is_immediate_test : integer_comparison -> int -> bool + method virtual is_immediate_test : Mach.integer_comparison -> int -> bool (* Selection of addressing modes *) @@ -145,7 +150,7 @@ class virtual selector_generic = (* Default instruction selection for stores (of words) *) - method select_store is_assign addr arg = + method select_store is_assign addr arg : Mach.operation * Cmm.expression = Istore (Word_val, addr, is_assign), arg (* call marking methods, documented in selectgen.mli *) @@ -157,7 +162,7 @@ class virtual selector_generic = method mark_c_tailcall = if !Clflags.debug then contains_calls := true - method mark_instr = + method mark_instr : Mach.instruction_desc -> unit = function | Iop (Icall_ind | Icall_imm _ | Iextcall _ | Iprobe _) -> self#mark_call | Iop (Itailcall_ind | Itailcall_imm _) -> self#mark_tailcall @@ -176,7 +181,9 @@ class virtual selector_generic = (* Default instruction selection for operators *) - method select_operation op args _dbg = + method select_operation (op : Cmm.operation) (args : Cmm.expression list) + _dbg : Mach.operation * Cmm.expression list = + let open Mach in match op, args with | Capply _, Cconst_symbol (func, _dbg) :: rem -> Icall_imm { func }, rem | Capply _, _ -> Icall_ind, args @@ -257,33 +264,37 @@ class virtual selector_generic = | Cendregion, _ -> Iendregion, args | _ -> Misc.fatal_error "Selection.select_oper" - method private select_arith_comm op = - function + method private select_arith_comm (op : Mach.integer_operation) + (args : Cmm.expression list) : Mach.operation * Cmm.expression list = + match args with | [arg; Cconst_int (n, _)] when self#is_immediate op n -> Iintop_imm (op, n), [arg] | [Cconst_int (n, _); arg] when self#is_immediate op n -> Iintop_imm (op, n), [arg] - | args -> Iintop op, args + | _ -> Iintop op, args - method private select_arith op = - function + method private select_arith (op : Mach.integer_operation) + (args : Cmm.expression list) : Mach.operation * Cmm.expression list = + match args with | [arg; Cconst_int (n, _)] when self#is_immediate op n -> Iintop_imm (op, n), [arg] - | args -> Iintop op, args + | _ -> Iintop op, args - method private select_arith_comp cmp = - function - | [arg; Cconst_int (n, _)] when self#is_immediate (Icomp cmp) n -> + method private select_arith_comp (cmp : Mach.integer_comparison) + (args : Cmm.expression list) : Mach.operation * Cmm.expression list = + match args with + | [arg; Cconst_int (n, _)] when self#is_immediate (Mach.Icomp cmp) n -> Iintop_imm (Icomp cmp, n), [arg] | [Cconst_int (n, _); arg] - when self#is_immediate (Icomp (swap_intcomp cmp)) n -> - Iintop_imm (Icomp (swap_intcomp cmp), n), [arg] - | args -> Iintop (Icomp cmp), args + when self#is_immediate (Mach.Icomp (Select_utils.swap_intcomp cmp)) n -> + Iintop_imm (Icomp (Select_utils.swap_intcomp cmp), n), [arg] + | _ -> Iintop (Icomp cmp), args (* Instruction selection for conditionals *) - method select_condition = - function + method select_condition (arg : Cmm.expression) : Mach.test * Cmm.expression + = + match arg with | Cop (Ccmpi cmp, [arg1; Cconst_int (n, _)], _) when self#is_immediate_test (Isigned cmp) n -> Iinttest_imm (Isigned cmp, n), arg1 @@ -301,8 +312,8 @@ class virtual selector_generic = | Cop (Ccmpa cmp, args, _) -> Iinttest (Iunsigned cmp), Ctuple args | Cop (Ccmpf (width, cmp), args, _) -> Ifloattest (width, cmp), Ctuple args - | Cop (Cand, [arg; Cconst_int (1, _)], _) -> Ioddtest, arg - | arg -> Itruetest, arg + | Cop (Cand, [arg1; Cconst_int (1, _)], _) -> Ioddtest, arg1 + | _ -> Itruetest, arg (* Return an array of fresh registers of the given type. Normally implemented as Reg.createv, but some ports (e.g. Arm) can override this @@ -312,28 +323,30 @@ class virtual selector_generic = (* Buffering of instruction sequences *) - val mutable instr_seq = dummy_instr + val mutable instr_seq = Mach.dummy_instr method insert_debug _env desc dbg arg res = - instr_seq <- instr_cons_debug desc arg res dbg instr_seq + instr_seq <- Mach.instr_cons_debug desc arg res dbg instr_seq method insert _env desc arg res = (* CR mshinwell: fix debuginfo *) - instr_seq <- instr_cons_debug desc arg res Debuginfo.none instr_seq + instr_seq <- Mach.instr_cons_debug desc arg res Debuginfo.none instr_seq - method extract_onto o = + method extract_onto (o : Mach.instruction) : Mach.instruction = let rec extract res i = - if i == dummy_instr then res else extract { i with next = res } i.next + if i == Mach.dummy_instr + then res + else extract { i with Mach.next = res } i.Mach.next in extract o instr_seq - method extract = self#extract_onto (end_instr ()) + method extract = self#extract_onto (Mach.end_instr ()) (* Insert a sequence of moves from one pseudoreg set to another. *) method insert_move env src dst = - if src.stamp <> dst.stamp - then self#insert env (Iop Imove) [| src |] [| dst |] + if src.Reg.stamp <> dst.Reg.stamp + then self#insert env Mach.(Iop Imove) [| src |] [| dst |] method insert_moves env src dst = for i = 0 to min (Array.length src) (Array.length dst) - 1 do @@ -344,20 +357,20 @@ class virtual selector_generic = method insert_move_args env arg loc stacksize = if stacksize <> 0 - then self#insert env (Iop (Istackoffset stacksize)) [||] [||]; + then self#insert env Mach.(Iop (Istackoffset stacksize)) [||] [||]; self#insert_moves env arg loc method insert_move_results env loc res stacksize = self#insert_moves env loc res; if stacksize <> 0 - then self#insert env (Iop (Istackoffset (-stacksize))) [||] [||] + then self#insert env Mach.(Iop (Istackoffset (-stacksize))) [||] [||] (* Add an Iop opcode. Can be overridden by processor description to insert moves before and after the operation, i.e. for two-address instructions, or instructions using dedicated registers. *) method insert_op_debug env op dbg rs rd = - self#insert_debug env (Iop op) dbg rs rd; + self#insert_debug env Mach.(Iop op) dbg rs rd; rd method insert_op env op rs rd = @@ -386,19 +399,25 @@ class virtual selector_generic = match exp with | Cconst_int (n, _dbg) -> let r = self#regs_for typ_int in - ret (self#insert_op env (Iconst_int (Nativeint.of_int n)) [||] r) + ret (self#insert_op env (Mach.Iconst_int (Nativeint.of_int n)) [||] r) | Cconst_natint (n, _dbg) -> let r = self#regs_for typ_int in - ret (self#insert_op env (Iconst_int n) [||] r) + ret (self#insert_op env (Mach.Iconst_int n) [||] r) | Cconst_float32 (n, _dbg) -> let r = self#regs_for typ_float32 in - ret (self#insert_op env (Iconst_float32 (Int32.bits_of_float n)) [||] r) + ret + (self#insert_op env + (Mach.Iconst_float32 (Int32.bits_of_float n)) + [||] r) | Cconst_float (n, _dbg) -> let r = self#regs_for typ_float in - ret (self#insert_op env (Iconst_float (Int64.bits_of_float n)) [||] r) + ret + (self#insert_op env + (Mach.Iconst_float (Int64.bits_of_float n)) + [||] r) | Cconst_vec128 (bits, _dbg) -> let r = self#regs_for typ_vec128 in - ret (self#insert_op env (Iconst_vec128 bits) [||] r) + ret (self#insert_op env (Mach.Iconst_vec128 bits) [||] r) | Cconst_symbol (n, _dbg) -> (* Cconst_symbol _ evaluates to a statically-allocated address, so its value fits in a typ_int register and is never changed by the GC. @@ -408,9 +427,9 @@ class virtual selector_generic = registered in the compilation unit's global roots structure, so adding this register to the frame table would be redundant *) let r = self#regs_for typ_int in - ret (self#insert_op env (Iconst_symbol n) [||] r) + ret (self#insert_op env (Mach.Iconst_symbol n) [||] r) | Cvar v -> ( - try ret (env_find v env) + try ret (Select_utils.env_find v env) with Not_found -> Misc.fatal_error ("Selection.emit_expr: unbound var " ^ V.unique_name v)) @@ -427,7 +446,7 @@ class virtual selector_generic = self#emit_expr_aux env body ~bound_name | Cassign (v, e1) -> ( let rv, provenance = - try env_find_mut v env + try Select_utils.env_find_mut v env with Not_found -> Misc.fatal_error ("Selection.emit_expr: unbound var " ^ V.name v) in @@ -437,7 +456,7 @@ class virtual selector_generic = (if Option.is_some provenance then let naming_op = - Iname_for_debugger + Mach.Iname_for_debugger { ident = v; provenance; which_parameter = None; @@ -445,7 +464,7 @@ class virtual selector_generic = regs = r1 } in - self#insert_debug env (Iop naming_op) Debuginfo.none [||] [||]); + self#insert_debug env (Mach.Iop naming_op) Debuginfo.none [||] [||]); self#insert_moves env r1 rv; ret [||]) | Ctuple [] -> ret [||] @@ -459,16 +478,16 @@ class virtual selector_generic = | None -> None | Some r1 -> let rd = [| Proc.loc_exn_bucket |] in - self#insert env (Iop Imove) r1 rd; - self#insert_debug env (Iraise k) dbg rd [||]; - set_traps_for_raise env; + self#insert env (Mach.Iop Imove) r1 rd; + self#insert_debug env (Mach.Iraise k) dbg rd [||]; + Select_utils.set_traps_for_raise env; None) | Cop (Copaque, args, dbg) -> ( match self#emit_parts_list env args with | None -> None | Some (simple_args, env) -> let rs = self#emit_tuple env simple_args in - ret (self#insert_op_debug env Iopaque dbg rs rs)) + ret (self#insert_op_debug env Mach.Iopaque dbg rs rs)) | Cop (Ctuple_field (field, fields_layout), [arg], _dbg) -> ( match self#emit_expr env arg ~bound_name:None with | None -> None @@ -496,7 +515,7 @@ class virtual selector_generic = then let bound_name = VP.var bound_name in let naming_op = - Iname_for_debugger + Mach.Iname_for_debugger { ident = bound_name; provenance; which_parameter = None; @@ -504,9 +523,10 @@ class virtual selector_generic = regs } in - self#insert_debug env (Iop naming_op) Debuginfo.none [||] [||] + self#insert_debug env (Mach.Iop naming_op) Debuginfo.none [||] + [||] in - let ty = oper_result_type op in + let ty = Select_utils.oper_result_type op in let new_op, new_args = self#select_operation op simple_args dbg in match new_op with | Icall_ind -> @@ -517,7 +537,7 @@ class virtual selector_generic = let loc_res, stack_ofs_res = Proc.loc_results_call (Reg.typv rd) in let stack_ofs = Stdlib.Int.max stack_ofs_args stack_ofs_res in self#insert_move_args env rarg loc_arg stack_ofs; - self#insert_debug env (Iop new_op) dbg + self#insert_debug env (Mach.Iop new_op) dbg (Array.append [| r1.(0) |] loc_arg) loc_res; (* The destination registers (as per the procedure calling @@ -526,7 +546,7 @@ class virtual selector_generic = after the call. *) add_naming_op_for_bound_name loc_res; self#insert_move_results env loc_res rd stack_ofs; - set_traps_for_raise env; + Select_utils.set_traps_for_raise env; Some rd | Icall_imm _ -> let r1 = self#emit_tuple env new_args in @@ -535,10 +555,10 @@ class virtual selector_generic = let loc_res, stack_ofs_res = Proc.loc_results_call (Reg.typv rd) in let stack_ofs = Stdlib.Int.max stack_ofs_args stack_ofs_res in self#insert_move_args env r1 loc_arg stack_ofs; - self#insert_debug env (Iop new_op) dbg loc_arg loc_res; + self#insert_debug env (Mach.Iop new_op) dbg loc_arg loc_res; add_naming_op_for_bound_name loc_res; self#insert_move_results env loc_res rd stack_ofs; - set_traps_for_raise env; + Select_utils.set_traps_for_raise env; Some rd | Iextcall ({ func; ty_args; returns; _ } as r) -> let loc_arg, stack_ofs = @@ -546,7 +566,7 @@ class virtual selector_generic = in let keep_for_checking = (not returns) - && !current_function_is_check_enabled + && !Select_utils.current_function_is_check_enabled && String.equal func Cmm.caml_flambda2_invalid in let returns, ty = @@ -555,35 +575,35 @@ class virtual selector_generic = let rd = self#regs_for ty in let loc_res = self#insert_op_debug env - (Iextcall { r with stack_ofs; returns }) + (Mach.Iextcall { r with stack_ofs; returns }) dbg loc_arg (Proc.loc_external_results (Reg.typv rd)) in add_naming_op_for_bound_name loc_res; self#insert_move_results env loc_res rd stack_ofs; - set_traps_for_raise env; + Select_utils.set_traps_for_raise env; if returns then ret rd else None | Ialloc { bytes = _; mode } -> let rd = self#regs_for typ_val in - let bytes = size_expr env (Ctuple new_args) in + let bytes = Select_utils.size_expr env (Ctuple new_args) in let alloc_words = (bytes + Arch.size_addr - 1) / Arch.size_addr in let op = - Ialloc + Mach.Ialloc { bytes = alloc_words * Arch.size_addr; dbginfo = [{ alloc_words; alloc_dbg = dbg }]; mode } in - self#insert_debug env (Iop op) dbg [||] rd; + self#insert_debug env (Mach.Iop op) dbg [||] rd; add_naming_op_for_bound_name rd; self#emit_stores env dbg new_args rd; - set_traps_for_raise env; + Select_utils.set_traps_for_raise env; ret rd | Iprobe _ -> let r1 = self#emit_tuple env new_args in let rd = self#regs_for ty in let rd = self#insert_op_debug env new_op dbg r1 rd in - set_traps_for_raise env; + Select_utils.set_traps_for_raise env; ret rd | op -> let r1 = self#emit_tuple env new_args in @@ -603,9 +623,9 @@ class virtual selector_generic = let relse, (selse : 'self) = self#emit_sequence env eelse ~bound_name in - let r = join env rif sif relse selse ~bound_name in + let r = Select_utils.join env rif sif relse selse ~bound_name in self#insert_debug env - (Iifthenelse (cond, sif#extract, selse#extract)) + (Mach.Iifthenelse (cond, sif#extract, selse#extract)) dbg rarg [||]; r) | Cswitch (esel, index, ecases, dbg, _kind) -> ( @@ -617,9 +637,9 @@ class virtual selector_generic = (fun (case, _dbg) -> self#emit_sequence env case ~bound_name) ecases in - let r = join_array env rscases ~bound_name in + let r = Select_utils.join_array env rscases ~bound_name in self#insert_debug env - (Iswitch (index, Array.map (fun (_, s) -> s#extract) rscases)) + (Mach.Iswitch (index, Array.map (fun (_, s) -> s#extract) rscases)) dbg rsel [||]; r) | Ccatch (_, [], e1, _) -> self#emit_expr_aux env e1 ~bound_name @@ -631,7 +651,7 @@ class virtual selector_generic = List.map (fun (id, typ) -> let r = self#regs_for typ in - name_regs id r; + Select_utils.name_regs id r; r) ids in @@ -644,7 +664,7 @@ class virtual selector_generic = body. *) List.fold_left (fun (env, map) (nfail, ids, rs, e2, dbg, is_cold) -> - let env, r = env_add_static_exception nfail rs env in + let env, r = Select_utils.env_add_static_exception nfail rs env in env, Int.Map.add nfail (r, (ids, rs, e2, dbg, is_cold)) map) (env, Int.Map.empty) handlers in @@ -653,15 +673,15 @@ class virtual selector_generic = (traps_info, (ids, rs, e2, _dbg, is_cold)) = assert (List.length ids = List.length rs); let trap_stack = - match !traps_info with + match (!traps_info : Select_utils.trap_stack_info) with | Unreachable -> assert false | Reachable t -> t in let ids_and_rs = List.combine ids rs in let new_env = List.fold_left - (fun env ((id, _typ), r) -> env_add id r env) - (env_set_trap_stack env trap_stack) + (fun env ((id, _typ), r) -> Select_utils.env_add id r env) + (Select_utils.env_set_trap_stack env trap_stack) ids_and_rs in let r, s = @@ -673,7 +693,7 @@ class virtual selector_generic = then let var = VP.var var in let naming_op = - Iname_for_debugger + Mach.Iname_for_debugger { ident = var; provenance; which_parameter = None; @@ -681,15 +701,17 @@ class virtual selector_generic = regs = r } in - seq#insert_debug env (Iop naming_op) Debuginfo.none [||] - [||]) + seq#insert_debug env (Mach.Iop naming_op) Debuginfo.none + [||] [||]) ids_and_rs) in (nfail, trap_stack, is_cold), (r, s) in let rec build_all_reachable_handlers ~already_built ~not_built = let not_built, to_build = - Int.Map.partition (fun _n (r, _) -> !r = Unreachable) not_built + Int.Map.partition + (fun _n (r, _) -> !r = Select_utils.Unreachable) + not_built in if Int.Map.is_empty to_build then already_built @@ -707,7 +729,7 @@ class virtual selector_generic = (* Note: we're dropping unreachable handlers here *) in let a = Array.of_list ((r_body, s_body) :: List.map snd l) in - let r = join_array env a ~bound_name in + let r = Select_utils.join_array env a ~bound_name in let aux ((nfail, ts, is_cold), (_r, s)) = nfail, ts, s#extract, is_cold in @@ -726,7 +748,8 @@ class virtual selector_generic = ts) in self#insert env - (Icatch (rec_flag, final_trap_stack, List.map aux l, s_body#extract)) + (Mach.Icatch + (rec_flag, final_trap_stack, List.map aux l, s_body#extract)) [||] [||]; r | Cexit (lbl, args, traps) -> ( @@ -737,7 +760,7 @@ class virtual selector_generic = | Lbl nfail -> let src = self#emit_tuple ext_env simple_list in let handler = - try env_find_static_exception nfail env + try Select_utils.env_find_static_exception nfail env with Not_found -> Misc.fatal_error ("Selection.emit_expr: unbound label " @@ -747,11 +770,11 @@ class virtual selector_generic = src are present in dest *) let tmp_regs = Reg.createv_like src in (* Ccatch registers must not contain out of heap pointers *) - Array.iter (fun reg -> assert (reg.typ <> Addr)) src; + Array.iter (fun reg -> assert (reg.Reg.typ <> Addr)) src; self#insert_moves env src tmp_regs; self#insert_moves env tmp_regs (Array.concat handler.regs); - self#insert env (Iexit (nfail, traps)) [||] [||]; - set_traps nfail handler.traps_ref env.trap_stack traps; + self#insert env (Mach.Iexit (nfail, traps)) [||] [||]; + Select_utils.set_traps nfail handler.traps_ref env.trap_stack traps; None | Return_lbl -> ( match simple_list with @@ -764,7 +787,7 @@ class virtual selector_generic = Misc.fatal_error "Selection.emit_expr: Return with too many arguments"))) | Ctrywith (e1, exn_cont, v, e2, dbg, _value_kind) -> ( - let env_body = env_enter_trywith env exn_cont in + let env_body = Select_utils.env_enter_trywith env exn_cont in let r1, s1 = self#emit_sequence env_body e1 ~bound_name in let rv = self#regs_for typ_val in let with_handler env_handler e2 = @@ -775,7 +798,7 @@ class virtual selector_generic = then let var = VP.var v in let naming_op = - Iname_for_debugger + Mach.Iname_for_debugger { ident = var; provenance; which_parameter = None; @@ -783,23 +806,24 @@ class virtual selector_generic = regs = rv } in - seq#insert_debug env (Iop naming_op) Debuginfo.none [||] [||]) + seq#insert_debug env (Mach.Iop naming_op) Debuginfo.none [||] + [||]) in - let r = join env r1 s1 r2 s2 ~bound_name in + let r = Select_utils.join env r1 s1 r2 s2 ~bound_name in self#insert env - (Itrywith + (Mach.Itrywith ( s1#extract, exn_cont, - ( env_handler.trap_stack, - instr_cons_debug (Iop Imove) [| Proc.loc_exn_bucket |] rv dbg - s2#extract ) )) + ( env_handler.Select_utils.trap_stack, + Mach.instr_cons_debug (Mach.Iop Imove) + [| Proc.loc_exn_bucket |] rv dbg s2#extract ) )) [||] [||]; r in - let env = env_add v rv env in - match env_find_static_exception exn_cont env_body with + let env = Select_utils.env_add v rv env in + match Select_utils.env_find_static_exception exn_cont env_body with | { traps_ref = { contents = Reachable ts }; _ } -> - with_handler (env_set_trap_stack env ts) e2 + with_handler (Select_utils.env_set_trap_stack env ts) e2 | { traps_ref = { contents = Unreachable }; _ } -> let dummy_constant = Cconst_int (1, Debuginfo.none) in let segfault = @@ -824,7 +848,7 @@ class virtual selector_generic = the function. *) Csequence (segfault, dummy_raise) in - let env = env_set_trap_stack env Uncaught in + let env = Select_utils.env_set_trap_stack env Uncaught in with_handler env unreachable (* Misc.fatal_errorf "Selection.emit_expr: \ * Unreachable exception handler %d" lbl *) @@ -833,28 +857,28 @@ class virtual selector_generic = method private emit_sequence ?at_start (env : environment) exp ~bound_name : _ * 'self = - let s : 'self = {} in + let s : 'self = {} in (match at_start with None -> () | Some f -> f s); let r = s#emit_expr_aux env exp ~bound_name in r, s method private bind_let (env : environment) v r1 = let env = - if all_regs_anonymous r1 + if Select_utils.all_regs_anonymous r1 then ( - name_regs v r1; - env_add v r1 env) + Select_utils.name_regs v r1; + Select_utils.env_add v r1 env) else let rv = Reg.createv_like r1 in - name_regs v rv; + Select_utils.name_regs v rv; self#insert_moves env r1 rv; - env_add v rv env + Select_utils.env_add v rv env in let provenance = VP.provenance v in (if Option.is_some provenance then let naming_op = - Iname_for_debugger + Mach.Iname_for_debugger { ident = VP.var v; which_parameter = None; provenance; @@ -862,18 +886,18 @@ class virtual selector_generic = regs = r1 } in - self#insert_debug env (Iop naming_op) Debuginfo.none [||] [||]); + self#insert_debug env (Mach.Iop naming_op) Debuginfo.none [||] [||]); env method private bind_let_mut (env : environment) v k r1 = let rv = self#regs_for k in - name_regs v rv; + Select_utils.name_regs v rv; self#insert_moves env r1 rv; let provenance = VP.provenance v in (if Option.is_some provenance then let naming_op = - Iname_for_debugger + Mach.Iname_for_debugger { ident = VP.var v; which_parameter = None; provenance = VP.provenance v; @@ -881,8 +905,8 @@ class virtual selector_generic = regs = r1 } in - self#insert_debug env (Iop naming_op) Debuginfo.none [||] [||]); - env_add ~mut:Mutable v rv env + self#insert_debug env (Mach.Iop naming_op) Debuginfo.none [||] [||]); + Select_utils.env_add ~mut:Mutable v rv env (* The following two functions, [emit_parts] and [emit_parts_list], force right-to-left evaluation order as required by the Flambda [Un_anf] pass @@ -893,7 +917,7 @@ class virtual selector_generic = let may_defer_evaluation = let ec = self#effects_of exp in match EC.effect ec with - | Effect.Arbitrary | Effect.Raise -> + | Select_utils.Effect.Arbitrary | Select_utils.Effect.Raise -> (* Preserve the ordering of effectful expressions by evaluating them early (in the correct order) and assigning their results to temporaries. We can avoid this in just one case: if we know that @@ -904,25 +928,25 @@ class virtual selector_generic = to check copurity too to avoid e.g. moving mutable reads earlier than the raising of an exception.) *) EC.pure_and_copure effects_after - | Effect.None -> ( + | Select_utils.Effect.None -> ( match EC.coeffect ec with - | Coeffect.None -> + | Select_utils.Coeffect.None -> (* Pure expressions may be moved. *) true - | Coeffect.Read_mutable -> ( + | Select_utils.Coeffect.Read_mutable -> ( (* Read-mutable expressions may only be deferred if evaluation of every [exp'] (for [exp'] as in the comment above) has no effects "worse" (in the sense of the ordering in [Effect.t]) than raising an exception. *) match EC.effect effects_after with - | Effect.None | Effect.Raise -> true - | Effect.Arbitrary -> false) - | Coeffect.Arbitrary -> ( + | Select_utils.Effect.None | Select_utils.Effect.Raise -> true + | Select_utils.Effect.Arbitrary -> false) + | Select_utils.Coeffect.Arbitrary -> ( (* Arbitrary expressions may only be deferred if evaluation of every [exp'] (for [exp'] as in the comment above) has no effects. *) match EC.effect effects_after with - | Effect.None -> true - | Effect.Arbitrary | Effect.Raise -> false)) + | Select_utils.Effect.None -> true + | Select_utils.Effect.(Arbitrary | Raise) -> false)) in (* Even though some expressions may look like they can be deferred from the (co)effect analysis, it may be forbidden to move them. *) @@ -937,15 +961,15 @@ class virtual selector_generic = else (* The normal case *) let id = V.create_local "bind" in - if all_regs_anonymous r + if Select_utils.all_regs_anonymous r then (* r is an anonymous, unshared register; use it directly *) - Some (Cvar id, env_add (VP.create id) r env) + Some (Cvar id, Select_utils.env_add (VP.create id) r env) else (* Introduce a fresh temp to hold the result *) let tmp = Reg.createv_like r in self#insert_moves env r tmp; - Some (Cvar id, env_add (VP.create id) tmp env) + Some (Cvar id, Select_utils.env_add (VP.create id) tmp env) method private emit_parts_list (env : environment) exp_list = let module EC = Select_utils.Effect_and_coeffect in @@ -993,7 +1017,7 @@ class virtual selector_generic = let locs, stack_ofs = Proc.loc_external_arguments ty_args in let ty_args = Array.of_list ty_args in if stack_ofs <> 0 - then self#insert env (Iop (Istackoffset stack_ofs)) [||] [||]; + then self#insert env (Mach.Iop (Istackoffset stack_ofs)) [||] [||]; List.iteri (fun i arg -> self#insert_move_extcall_arg env ty_args.(i) arg locs.(i)) args; @@ -1021,7 +1045,7 @@ class virtual selector_generic = for i = 0 to Array.length regs - 1 do let r = regs.(i) in let kind = - match r.typ with + match r.Reg.typ with | Float -> Double | Float32 -> Single { reg = Float32 } | Vec128 -> @@ -1031,17 +1055,19 @@ class virtual selector_generic = | Val | Addr | Int -> Word_val in self#insert_debug env - (Iop (Istore (kind, !a, false))) + (Mach.Iop (Istore (kind, !a, false))) dbg (Array.append [| r |] regs_addr) [||]; - a := Arch.offset_addressing !a (size_component r.typ) + a + := Arch.offset_addressing !a + (Select_utils.size_component r.Reg.typ) done | _ -> - self#insert_debug env (Iop op) dbg + self#insert_debug env (Mach.Iop op) dbg (Array.append regs regs_addr) [||]; - a := Arch.offset_addressing !a (size_expr env e))) + a := Arch.offset_addressing !a (Select_utils.size_expr env e))) data (* Same, but in tail position *) @@ -1053,7 +1079,7 @@ class virtual selector_generic = | Some r -> let loc = Proc.loc_results_return (Reg.typv r) in self#insert_moves env r loc; - self#insert env (Ireturn traps) loc [||] + self#insert env (Mach.Ireturn traps) loc [||] method private emit_return (env : environment) exp traps = self#insert_return env (self#emit_expr_aux env exp ~bound_name:None) traps @@ -1084,45 +1110,49 @@ class virtual selector_generic = let loc_arg, stack_ofs_args = Proc.loc_arguments (Reg.typv rarg) in let loc_res, stack_ofs_res = Proc.loc_results_call (Reg.typv rd) in let stack_ofs = Stdlib.Int.max stack_ofs_args stack_ofs_res in - if stack_ofs = 0 && trap_stack_is_empty env + if stack_ofs = 0 && Select_utils.trap_stack_is_empty env then ( - let call = Iop Itailcall_ind in + let call = Mach.Iop Itailcall_ind in self#insert_moves env rarg loc_arg; self#insert_debug env call dbg (Array.append [| r1.(0) |] loc_arg) [||]) else ( self#insert_move_args env rarg loc_arg stack_ofs; - self#insert_debug env (Iop new_op) dbg + self#insert_debug env (Mach.Iop new_op) dbg (Array.append [| r1.(0) |] loc_arg) loc_res; - set_traps_for_raise env; - self#insert env (Iop (Istackoffset (-stack_ofs))) [||] [||]; - self#insert env (Ireturn (pop_all_traps env)) loc_res [||]) + Select_utils.set_traps_for_raise env; + self#insert env (Mach.Iop (Istackoffset (-stack_ofs))) [||] [||]; + self#insert env + (Mach.Ireturn (Select_utils.pop_all_traps env)) + loc_res [||]) | Icall_imm { func } -> let r1 = self#emit_tuple env new_args in let rd = self#regs_for ty in let loc_arg, stack_ofs_args = Proc.loc_arguments (Reg.typv r1) in let loc_res, stack_ofs_res = Proc.loc_results_call (Reg.typv rd) in let stack_ofs = Stdlib.Int.max stack_ofs_args stack_ofs_res in - if stack_ofs = 0 && trap_stack_is_empty env + if stack_ofs = 0 && Select_utils.trap_stack_is_empty env then ( - let call = Iop (Itailcall_imm { func }) in + let call = Mach.Iop (Itailcall_imm { func }) in self#insert_moves env r1 loc_arg; self#insert_debug env call dbg loc_arg [||]) - else if func.sym_name = !current_function_name - && trap_stack_is_empty env + else if func.sym_name = !Select_utils.current_function_name + && Select_utils.trap_stack_is_empty env then ( - let call = Iop (Itailcall_imm { func }) in + let call = Mach.Iop (Itailcall_imm { func }) in let loc_arg' = Proc.loc_parameters (Reg.typv r1) in self#insert_moves env r1 loc_arg'; self#insert_debug env call dbg loc_arg' [||]) else ( self#insert_move_args env r1 loc_arg stack_ofs; - self#insert_debug env (Iop new_op) dbg loc_arg loc_res; - set_traps_for_raise env; - self#insert env (Iop (Istackoffset (-stack_ofs))) [||] [||]; - self#insert env (Ireturn (pop_all_traps env)) loc_res [||]) + self#insert_debug env (Mach.Iop new_op) dbg loc_arg loc_res; + Select_utils.set_traps_for_raise env; + self#insert env (Mach.Iop (Istackoffset (-stack_ofs))) [||] [||]; + self#insert env + (Mach.Ireturn (Select_utils.pop_all_traps env)) + loc_res [||]) | _ -> Misc.fatal_error "Selection.emit_tail")) | Csequence (e1, e2) -> ( match self#emit_expr env e1 ~bound_name:None with @@ -1134,7 +1164,7 @@ class virtual selector_generic = | None -> () | Some rarg -> self#insert_debug env - (Iifthenelse + (Mach.Iifthenelse ( cond, self#emit_tail_sequence env eif, self#emit_tail_sequence env eelse )) @@ -1148,7 +1178,7 @@ class virtual selector_generic = (fun (case, _dbg) -> self#emit_tail_sequence env case) ecases in - self#insert_debug env (Iswitch (index, cases)) dbg rsel [||]) + self#insert_debug env (Mach.Iswitch (index, cases)) dbg rsel [||]) | Ccatch (_, [], e1, _) -> self#emit_tail env e1 | Ccatch (rec_flag, handlers, e1, _) -> let handlers = @@ -1158,7 +1188,7 @@ class virtual selector_generic = List.map (fun (id, typ) -> let r = self#regs_for typ in - name_regs id r; + Select_utils.name_regs id r; r) ids in @@ -1168,7 +1198,7 @@ class virtual selector_generic = let env, handlers_map = List.fold_left (fun (env, map) (nfail, ids, rs, e2, dbg, is_cold) -> - let env, r = env_add_static_exception nfail rs env in + let env, r = Select_utils.env_add_static_exception nfail rs env in env, Int.Map.add nfail (r, (ids, rs, e2, dbg, is_cold)) map) (env, Int.Map.empty) handlers in @@ -1177,15 +1207,15 @@ class virtual selector_generic = = assert (List.length ids = List.length rs); let trap_stack = - match !trap_info with + match (!trap_info : Select_utils.trap_stack_info) with | Unreachable -> assert false | Reachable t -> t in let ids_and_rs = List.combine ids rs in let new_env = List.fold_left - (fun env ((id, _typ), r) -> env_add id r env) - (env_set_trap_stack env trap_stack) + (fun env ((id, _typ), r) -> Select_utils.env_add id r env) + (Select_utils.env_set_trap_stack env trap_stack) ids_and_rs in let seq = @@ -1197,7 +1227,7 @@ class virtual selector_generic = then let var = VP.var var in let naming_op = - Iname_for_debugger + Mach.Iname_for_debugger { ident = var; provenance; which_parameter = None; @@ -1205,15 +1235,17 @@ class virtual selector_generic = regs = r } in - seq#insert_debug new_env (Iop naming_op) Debuginfo.none - [||] [||]) + seq#insert_debug new_env (Mach.Iop naming_op) + Debuginfo.none [||] [||]) ids_and_rs) in nfail, trap_stack, seq, is_cold in let rec build_all_reachable_handlers ~already_built ~not_built = let not_built, to_build = - Int.Map.partition (fun _n (r, _) -> !r = Unreachable) not_built + Int.Map.partition + (fun _n (r, _) -> !r = Select_utils.Unreachable) + not_built in if Int.Map.is_empty to_build then already_built @@ -1232,10 +1264,10 @@ class virtual selector_generic = in (* The final trap stack doesn't matter, as it's not reachable. *) self#insert env - (Icatch (rec_flag, env.trap_stack, new_handlers, s_body)) + (Mach.Icatch (rec_flag, env.trap_stack, new_handlers, s_body)) [||] [||] | Ctrywith (e1, exn_cont, v, e2, dbg, _value_kind) -> ( - let env_body = env_enter_trywith env exn_cont in + let env_body = Select_utils.env_enter_trywith env exn_cont in let s1 = self#emit_tail_sequence env_body e1 in let rv = self#regs_for typ_val in let with_handler env_handler e2 = @@ -1246,7 +1278,7 @@ class virtual selector_generic = then let var = VP.var v in let naming_op = - Iname_for_debugger + Mach.Iname_for_debugger { ident = var; provenance; which_parameter = None; @@ -1254,22 +1286,22 @@ class virtual selector_generic = regs = rv } in - seq#insert_debug env_handler (Iop naming_op) Debuginfo.none - [||] [||]) + seq#insert_debug env_handler (Mach.Iop naming_op) + Debuginfo.none [||] [||]) in self#insert env - (Itrywith + (Mach.Itrywith ( s1, exn_cont, - ( env_handler.trap_stack, - instr_cons_debug (Iop Imove) [| Proc.loc_exn_bucket |] rv dbg - s2 ) )) + ( env_handler.Select_utils.trap_stack, + Mach.instr_cons_debug (Iop Imove) [| Proc.loc_exn_bucket |] + rv dbg s2 ) )) [||] [||] in - let env = env_add v rv env in - match env_find_static_exception exn_cont env_body with + let env = Select_utils.env_add v rv env in + match Select_utils.env_find_static_exception exn_cont env_body with | { traps_ref = { contents = Reachable ts }; _ } -> - with_handler (env_set_trap_stack env ts) e2 + with_handler (Select_utils.env_set_trap_stack env ts) e2 | { traps_ref = { contents = Unreachable }; _ } -> (* Note: The following [unreachable] expression has machtype [|Int|], but this might not be the correct machtype for this function's @@ -1296,10 +1328,10 @@ class virtual selector_generic = | Cop _ | Cconst_int _ | Cconst_natint _ | Cconst_float32 _ | Cconst_float _ | Cconst_symbol _ | Cconst_vec128 _ | Cvar _ | Cassign _ | Ctuple _ | Cexit _ -> - self#emit_return env exp (pop_all_traps env) + self#emit_return env exp (Select_utils.pop_all_traps env) method private emit_tail_sequence ?at_start env exp = - let s = {} in + let s = {} in (match at_start with None -> () | Some f -> f s); s#emit_tail env exp; s#extract @@ -1307,8 +1339,8 @@ class virtual selector_generic = (* Sequentialization of a function definition *) method emit_fundecl ~future_funcnames f = - current_function_name := f.Cmm.fun_name.sym_name; - current_function_is_check_enabled + Select_utils.current_function_name := f.Cmm.fun_name.sym_name; + Select_utils.current_function_is_check_enabled := Zero_alloc_checker.is_check_enabled f.Cmm.fun_codegen_options f.Cmm.fun_name.sym_name f.Cmm.fun_dbg; let num_regs_per_arg = Array.make (List.length f.Cmm.fun_args) 0 in @@ -1316,7 +1348,7 @@ class virtual selector_generic = List.mapi (fun arg_index (var, ty) -> let r = self#regs_for ty in - name_regs var r; + Select_utils.name_regs var r; num_regs_per_arg.(arg_index) <- Array.length r; r) f.Cmm.fun_args @@ -1325,12 +1357,12 @@ class virtual selector_generic = let loc_arg = Proc.loc_parameters (Reg.typv rarg) in let env = List.fold_right2 - (fun (id, _ty) r env -> env_add id r env) - f.Cmm.fun_args rargs env_empty + (fun (id, _ty) r env -> Select_utils.env_add id r env) + f.Cmm.fun_args rargs Select_utils.env_empty in self#emit_tail env f.Cmm.fun_body; let body = self#extract in - instr_seq <- dummy_instr; + instr_seq <- Mach.dummy_instr; let loc_arg_index = ref 0 in List.iteri (fun param_index (var, _ty) -> @@ -1345,7 +1377,7 @@ class virtual selector_generic = if Option.is_some provenance then let naming_op = - Iname_for_debugger + Mach.Iname_for_debugger { ident = var; provenance; which_parameter = Some param_index; @@ -1353,7 +1385,7 @@ class virtual selector_generic = regs = hard_regs_for_arg } in - self#insert_debug env (Iop naming_op) Debuginfo.none + self#insert_debug env (Mach.Iop naming_op) Debuginfo.none hard_regs_for_arg [||]) f.Cmm.fun_args; self#insert_moves env loc_arg rarg; @@ -1361,16 +1393,16 @@ class virtual selector_generic = if Polling.requires_prologue_poll ~future_funcnames ~fun_name:f.Cmm.fun_name.sym_name body then - instr_cons_debug + Mach.instr_cons_debug (Iop (Ipoll { return_label = None })) [||] [||] f.Cmm.fun_dbg body else body in let body_with_prologue = self#extract_onto polled_body in - instr_iter + Mach.instr_iter (fun instr -> self#mark_instr instr.Mach.desc) body_with_prologue; - { fun_name = f.Cmm.fun_name.sym_name; + { Mach.fun_name = f.Cmm.fun_name.sym_name; fun_args = loc_arg; fun_body = body_with_prologue; fun_codegen_options = f.Cmm.fun_codegen_options; diff --git a/backend/selectgen.mli b/backend/selectgen.mli index 481646ab81b..214327f9fce 100644 --- a/backend/selectgen.mli +++ b/backend/selectgen.mli @@ -16,6 +16,8 @@ (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) +[@@@ocaml.warning "+a-4-9-40-41-42"] + class virtual selector_generic : object (* The following methods must or can be overridden by the processor From af24c98c6ffcc5f33fb9cf91f771affe1a7d04f1 Mon Sep 17 00:00:00 2001 From: Zesen Qian Date: Fri, 30 Aug 2024 13:54:29 +0100 Subject: [PATCH 04/76] Remove `get_single_mode_exn` (#3002) --- ocaml/typing/typecore.ml | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index 2cdfba372dc..8318a98be99 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -461,11 +461,6 @@ let as_single_mode {mode; tuple_modes; _} = | Some l -> Value.meet (mode :: l) | None -> mode -let get_single_mode_exn {mode; tuple_modes; _} = - match tuple_modes with - | Some _ -> Misc.fatal_error "tuple_modes should be None" - | None -> mode - let mode_morph f expected_mode = let mode = as_single_mode expected_mode in let mode = f mode |> Mode.Value.disallow_left in @@ -473,7 +468,7 @@ let mode_morph f expected_mode = {expected_mode with mode; tuple_modes} let mode_modality modality expected_mode = - get_single_mode_exn expected_mode + as_single_mode expected_mode |> Modality.Value.Const.apply modality |> mode_default @@ -631,7 +626,7 @@ let register_allocation_value_mode mode = of potential subcomponents. *) let register_allocation (expected_mode : expected_mode) = let alloc_mode, mode = - register_allocation_value_mode (get_single_mode_exn expected_mode) + register_allocation_value_mode (as_single_mode expected_mode) in let alloc_mode = { mode = alloc_mode; @@ -4753,7 +4748,7 @@ let split_function_ty to be made global if its inner function is global. As a result, a function deserves a separate allocation mode. *) - let mode, _ = Value.newvar_below (get_single_mode_exn expected_mode) in + let mode, _ = Value.newvar_below (as_single_mode expected_mode) in fst (register_allocation_value_mode mode) in if expected_mode.strictly_local then @@ -5074,7 +5069,7 @@ and type_expect_ in Texp_ident(path, lid, desc, kind, unique_use ~loc ~env actual_mode.mode - (get_single_mode_exn expected_mode)) + (as_single_mode expected_mode)) | _ -> Texp_ident(path, lid, desc, kind, unique_use ~loc ~env actual_mode.mode @@ -5595,7 +5590,7 @@ and type_expect_ submode ~loc ~env mode argument_mode; Kept (ty_arg1, lbl.lbl_mut, unique_use ~loc ~env mode - (get_single_mode_exn argument_mode)) + (as_single_mode argument_mode)) end in let label_definitions = Array.map unify_kept lbl.lbl_all in @@ -5658,7 +5653,7 @@ and type_expect_ let mode = mode_cross_left env Predef.type_unboxed_float mode in submode ~loc ~env mode argument_mode; let uu = - unique_use ~loc ~env mode (get_single_mode_exn argument_mode) + unique_use ~loc ~env mode (as_single_mode argument_mode) in Boxing (alloc_mode, uu) | false -> From 69aaaa19edea9cd3d129e2266c601a1d671822f3 Mon Sep 17 00:00:00 2001 From: Xavier Clerc Date: Fri, 30 Aug 2024 15:30:53 +0200 Subject: [PATCH 05/76] Selection: add extra data to environment (#3001) --- backend/select_utils.ml | 19 ++++++++-------- backend/select_utils.mli | 41 ++++++++++++++++++++--------------- backend/selectgen.ml | 14 +++++++----- backend/selectgen.mli | 47 ++++++++++++++-------------------------- 4 files changed, 58 insertions(+), 63 deletions(-) diff --git a/backend/select_utils.ml b/backend/select_utils.ml index 55bfd1ca73c..a2273350d30 100644 --- a/backend/select_utils.ml +++ b/backend/select_utils.ml @@ -27,16 +27,17 @@ type trap_stack_info = | Unreachable | Reachable of Mach.trap_stack -type static_handler = +type 'a static_handler = { regs : Reg.t array list; - traps_ref : trap_stack_info ref + traps_ref : trap_stack_info ref; + extra : 'a } -type environment = +type 'a environment = { vars : (Reg.t array * Backend_var.Provenance.t option * Asttypes.mutable_flag) V.Map.t; - static_exceptions : static_handler Int.Map.t; + static_exceptions : 'a static_handler Int.Map.t; (** Which registers must be populated when jumping to the given handler. *) trap_stack : Mach.trap_stack @@ -47,9 +48,9 @@ let env_add ?(mut = Asttypes.Immutable) var regs env = let var = VP.var var in { env with vars = V.Map.add var (regs, provenance, mut) env.vars } -let env_add_static_exception id v env = +let env_add_static_exception id v env extra = let r = ref Unreachable in - let s : static_handler = { regs = v; traps_ref = r } in + let s : _ static_handler = { regs = v; traps_ref = r; extra } in { env with static_exceptions = Int.Map.add id s env.static_exceptions }, r let env_find id env = @@ -68,8 +69,8 @@ let _env_find_with_provenance id env = V.Map.find id env.vars let env_find_static_exception id env = Int.Map.find id env.static_exceptions -let env_enter_trywith env id = - let env, _ = env_add_static_exception id [] env in +let env_enter_trywith env id extra = + let env, _ = env_add_static_exception id [] env extra in env let env_set_trap_stack env trap_stack = { env with trap_stack } @@ -219,7 +220,7 @@ let size_machtype mty = done; !size -let size_expr (env : environment) exp = +let size_expr (env : _ environment) exp = let rec size localenv = function | Cconst_int _ | Cconst_natint _ -> Arch.size_int | Cconst_symbol _ -> Arch.size_addr diff --git a/backend/select_utils.mli b/backend/select_utils.mli index f1421040a8d..85331646521 100644 --- a/backend/select_utils.mli +++ b/backend/select_utils.mli @@ -22,16 +22,17 @@ type trap_stack_info = | Unreachable | Reachable of Mach.trap_stack -type static_handler = +type 'a static_handler = { regs : Reg.t array list; - traps_ref : trap_stack_info ref + traps_ref : trap_stack_info ref; + extra : 'a } -type environment = +type 'a environment = { vars : (Reg.t array * Backend_var.Provenance.t option * Asttypes.mutable_flag) Backend_var.Map.t; - static_exceptions : static_handler Numbers.Int.Map.t; + static_exceptions : 'a static_handler Numbers.Int.Map.t; (** Which registers must be populated when jumping to the given handler. *) trap_stack : Mach.trap_stack @@ -41,26 +42,30 @@ val env_add : ?mut:Asttypes.mutable_flag -> Backend_var.With_provenance.t -> Reg.t array -> - environment -> - environment + 'a environment -> + 'a environment val env_add_static_exception : Lambda.static_label -> Reg.t array list -> - environment -> - environment * trap_stack_info ref + 'a environment -> + 'a -> + 'a environment * trap_stack_info ref -val env_find : Backend_var.t -> environment -> Reg.t array +val env_find : Backend_var.t -> 'a environment -> Reg.t array val env_find_mut : - Backend_var.t -> environment -> Reg.t array * Backend_var.Provenance.t option + Backend_var.t -> + 'a environment -> + Reg.t array * Backend_var.Provenance.t option val env_find_static_exception : - Lambda.static_label -> environment -> static_handler + Lambda.static_label -> 'a environment -> 'a static_handler -val env_enter_trywith : environment -> Cmm.trywith_shared_label -> environment +val env_enter_trywith : + 'a environment -> Cmm.trywith_shared_label -> 'a -> 'a environment -val env_set_trap_stack : environment -> Mach.trap_stack -> environment +val env_set_trap_stack : 'a environment -> Mach.trap_stack -> 'a environment val set_traps : Lambda.static_label -> @@ -69,17 +74,17 @@ val set_traps : Cmm.trap_action list -> unit -val set_traps_for_raise : environment -> unit +val set_traps_for_raise : 'a environment -> unit -val trap_stack_is_empty : environment -> bool +val trap_stack_is_empty : 'a environment -> bool -val pop_all_traps : environment -> Cmm.trap_action list +val pop_all_traps : 'a environment -> Cmm.trap_action list -val env_empty : environment +val env_empty : 'a environment val size_component : Cmm.machtype_component -> int -val size_expr : environment -> Cmm.expression -> int +val size_expr : 'a environment -> Cmm.expression -> int val select_mutable_flag : Asttypes.mutable_flag -> Mach.mutable_flag diff --git a/backend/selectgen.ml b/backend/selectgen.ml index bf8ebe2bb4c..c8761b65b59 100644 --- a/backend/selectgen.ml +++ b/backend/selectgen.ml @@ -25,7 +25,7 @@ module VP = Backend_var.With_provenance (* The default instruction selection class *) -type environment = Select_utils.environment +type environment = unit Select_utils.environment class virtual selector_generic = object (self : 'self) @@ -664,7 +664,9 @@ class virtual selector_generic = body. *) List.fold_left (fun (env, map) (nfail, ids, rs, e2, dbg, is_cold) -> - let env, r = Select_utils.env_add_static_exception nfail rs env in + let env, r = + Select_utils.env_add_static_exception nfail rs env () + in env, Int.Map.add nfail (r, (ids, rs, e2, dbg, is_cold)) map) (env, Int.Map.empty) handlers in @@ -787,7 +789,7 @@ class virtual selector_generic = Misc.fatal_error "Selection.emit_expr: Return with too many arguments"))) | Ctrywith (e1, exn_cont, v, e2, dbg, _value_kind) -> ( - let env_body = Select_utils.env_enter_trywith env exn_cont in + let env_body = Select_utils.env_enter_trywith env exn_cont () in let r1, s1 = self#emit_sequence env_body e1 ~bound_name in let rv = self#regs_for typ_val in let with_handler env_handler e2 = @@ -1198,7 +1200,9 @@ class virtual selector_generic = let env, handlers_map = List.fold_left (fun (env, map) (nfail, ids, rs, e2, dbg, is_cold) -> - let env, r = Select_utils.env_add_static_exception nfail rs env in + let env, r = + Select_utils.env_add_static_exception nfail rs env () + in env, Int.Map.add nfail (r, (ids, rs, e2, dbg, is_cold)) map) (env, Int.Map.empty) handlers in @@ -1267,7 +1271,7 @@ class virtual selector_generic = (Mach.Icatch (rec_flag, env.trap_stack, new_handlers, s_body)) [||] [||] | Ctrywith (e1, exn_cont, v, e2, dbg, _value_kind) -> ( - let env_body = Select_utils.env_enter_trywith env exn_cont in + let env_body = Select_utils.env_enter_trywith env exn_cont () in let s1 = self#emit_tail_sequence env_body e1 in let rv = self#regs_for typ_val in let with_handler env_handler e2 = diff --git a/backend/selectgen.mli b/backend/selectgen.mli index 214327f9fce..f943d0a3c4d 100644 --- a/backend/selectgen.mli +++ b/backend/selectgen.mli @@ -18,6 +18,8 @@ [@@@ocaml.warning "+a-4-9-40-41-42"] +type environment = unit Select_utils.environment + class virtual selector_generic : object (* The following methods must or can be overridden by the processor @@ -66,16 +68,12 @@ class virtual selector_generic : stored as pairs of integer registers. *) method insert_op : - Select_utils.environment -> - Mach.operation -> - Reg.t array -> - Reg.t array -> - Reg.t array + environment -> Mach.operation -> Reg.t array -> Reg.t array -> Reg.t array (* Can be overridden to deal with 2-address instructions or instructions with hardwired input/output registers *) method insert_op_debug : - Select_utils.environment -> + environment -> Mach.operation -> Debuginfo.t -> Reg.t array -> @@ -85,28 +83,20 @@ class virtual selector_generic : with hardwired input/output registers *) method insert_move_extcall_arg : - Select_utils.environment -> - Cmm.exttype -> - Reg.t array -> - Reg.t array -> - unit + environment -> Cmm.exttype -> Reg.t array -> Reg.t array -> unit (* Can be overridden to deal with unusual unboxed calling conventions, e.g. on a 64-bit platform, passing unboxed 32-bit arguments in 32-bit stack slots. *) method emit_extcall_args : - Select_utils.environment -> + environment -> Cmm.exttype list -> Cmm.expression list -> Reg.t array * int (* Can be overridden to deal with stack-based calling conventions *) method emit_stores : - Select_utils.environment -> - Debuginfo.t -> - Cmm.expression list -> - Reg.t array -> - unit + environment -> Debuginfo.t -> Cmm.expression list -> Reg.t array -> unit (* Fill a freshly allocated block. Can be overridden for architectures that do not provide Arch.offset_addressing. *) @@ -146,44 +136,39 @@ class virtual selector_generic : method extract : Mach.instruction method insert : - Select_utils.environment -> - Mach.instruction_desc -> - Reg.t array -> - Reg.t array -> - unit + environment -> Mach.instruction_desc -> Reg.t array -> Reg.t array -> unit method insert_debug : - Select_utils.environment -> + environment -> Mach.instruction_desc -> Debuginfo.t -> Reg.t array -> Reg.t array -> unit - method insert_move : Select_utils.environment -> Reg.t -> Reg.t -> unit + method insert_move : environment -> Reg.t -> Reg.t -> unit method insert_move_args : - Select_utils.environment -> Reg.t array -> Reg.t array -> int -> unit + environment -> Reg.t array -> Reg.t array -> int -> unit method insert_move_results : - Select_utils.environment -> Reg.t array -> Reg.t array -> int -> unit + environment -> Reg.t array -> Reg.t array -> int -> unit - method insert_moves : - Select_utils.environment -> Reg.t array -> Reg.t array -> unit + method insert_moves : environment -> Reg.t array -> Reg.t array -> unit method emit_expr : - Select_utils.environment -> + environment -> Cmm.expression -> bound_name:Backend_var.With_provenance.t option -> Reg.t array option method emit_expr_aux : - Select_utils.environment -> + environment -> Cmm.expression -> bound_name:Backend_var.With_provenance.t option -> Reg.t array option - method emit_tail : Select_utils.environment -> Cmm.expression -> unit + method emit_tail : environment -> Cmm.expression -> unit (* [contains_calls] is declared as a reference instance variable, instead of a mutable boolean instance variable, because the traversal uses From 8a165daaf85102e9eb73dc083ac1fe22636d86ff Mon Sep 17 00:00:00 2001 From: Zesen Qian Date: Fri, 30 Aug 2024 14:52:31 +0100 Subject: [PATCH 06/76] Fix mode zapping extra constraint (#2978) --- .../typing-modes/pr2979.compilers.reference | 5 + ocaml/testsuite/tests/typing-modes/pr2979.ml | 11 ++ ocaml/testsuite/tests/typing-modes/pr2979.mli | 0 ocaml/typing/env.ml | 5 +- ocaml/typing/solver.ml | 124 +++++++++--------- ocaml/typing/typecore.ml | 6 +- 6 files changed, 81 insertions(+), 70 deletions(-) create mode 100644 ocaml/testsuite/tests/typing-modes/pr2979.compilers.reference create mode 100644 ocaml/testsuite/tests/typing-modes/pr2979.ml create mode 100644 ocaml/testsuite/tests/typing-modes/pr2979.mli diff --git a/ocaml/testsuite/tests/typing-modes/pr2979.compilers.reference b/ocaml/testsuite/tests/typing-modes/pr2979.compilers.reference new file mode 100644 index 00000000000..d8dc6305638 --- /dev/null +++ b/ocaml/testsuite/tests/typing-modes/pr2979.compilers.reference @@ -0,0 +1,5 @@ +File "pr2979.ml", line 11, characters 23-35: +11 | let[@tail_mod_cons] f x = (42, 42) + ^^^^^^^^^^^^ +Warning 71 [unused-tmc-attribute]: This function is marked @tail_mod_cons +but is never applied in TMC position. diff --git a/ocaml/testsuite/tests/typing-modes/pr2979.ml b/ocaml/testsuite/tests/typing-modes/pr2979.ml new file mode 100644 index 00000000000..9871c0546ea --- /dev/null +++ b/ocaml/testsuite/tests/typing-modes/pr2979.ml @@ -0,0 +1,11 @@ +(* TEST + readonly_files = "pr2979.ml pr2979.mli"; +setup-ocamlc.byte-build-env; +module = "pr2979.mli"; +ocamlc.byte; +module = "pr2979.ml"; +ocamlc.byte; +check-ocamlc.byte-output; +*) + +let[@tail_mod_cons] f x = (42, 42) diff --git a/ocaml/testsuite/tests/typing-modes/pr2979.mli b/ocaml/testsuite/tests/typing-modes/pr2979.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/typing/env.ml b/ocaml/typing/env.ml index 66d7ceb8b9f..679bc4a6589 100644 --- a/ocaml/typing/env.ml +++ b/ocaml/typing/env.ml @@ -3044,9 +3044,8 @@ let share_mode ~errors ~env ~loc ~item ~lid vmode shared_context = (Once_value_used_in (item, lid, shared_context)) | Ok () -> let mode = - Mode.Value.join [ - Mode.Value.min_with (Monadic Uniqueness) Mode.Uniqueness.shared; - vmode.mode] + Mode.Value.join_with (Monadic Uniqueness) Mode.Uniqueness.Const.Shared + vmode.mode in {mode; context = Some shared_context} diff --git a/ocaml/typing/solver.ml b/ocaml/typing/solver.ml index fd8cabcc9ab..0224a60d5dc 100644 --- a/ocaml/typing/solver.ml +++ b/ocaml/typing/solver.ml @@ -382,33 +382,6 @@ module Solver_mono (C : Lattices_mono) = struct | Ok () -> Ok () | Error e -> Error (C.apply obj f e) - (** Zap [mv] to its lower bound. Returns the [log] of the zapping, in - case the caller are only interested in the lower bound and wants to - reverse the zapping. - - As mentioned in [var], [mlower mv] is not precise; to get the precise - lower bound of [mv], we call [submode mv (mlower mv)]. This will propagate - to all its children, which might fail because some children's lower bound - [a] is more up-to-date than [mv]. In that case, we call [submode mv a]. We - repeat this process until no failure, and we will get the precise lower - bound. - - The loop is guaranteed to terminate, because for each iteration our - guessed lower bound is strictly higher; and all lattices are finite. - *) - let zap_to_floor_morphvar_aux (type a r) (obj : a C.obj) - (mv : (a, allowed * r) morphvar) = - let rec loop lower = - let log = ref empty_changes in - let r = submode_mvc ~log:(Some log) obj mv lower in - match r with - | Ok () -> !log, lower - | Error a -> - undo_changes !log; - loop (C.join obj a lower) - in - loop (mlower obj mv) - let eq_morphvar : type a l0 r0 l1 r1. (a, l0 * r0) morphvar -> (a, l1 * r1) morphvar -> bool = @@ -510,20 +483,6 @@ module Solver_mono (C : Lattices_mono) = struct find_error (fun mv -> submode_mvmv ~log obj mv mu) mvs) mus))) - let zap_to_ceil_morphvar obj mv ~log = - assert (submode_cmv obj (mupper obj mv) mv ~log |> Result.is_ok); - mupper obj mv - - let zap_to_ceil : type a l. a C.obj -> (a, l * allowed) mode -> log:_ -> a = - fun obj m ~log -> - match m with - | Amode m -> m - | Amodevar mv -> zap_to_ceil_morphvar obj mv ~log - | Amodemeet (a, mvs) -> - List.fold_left - (fun acc mv -> C.meet obj acc (zap_to_ceil_morphvar obj mv ~log)) - a mvs - let cons_dedup x xs = if exists x xs then xs else x :: xs (* Similar to [List.rev_append] but dedup the result (assuming both inputs are @@ -584,28 +543,6 @@ module Solver_mono (C : Lattices_mono) = struct in loop (C.max obj) [] l - (** Zaps a morphvar to its floor and returns the floor. [commit] could be - [Some log], in which case the zapping is appended to [log]; it could also - be [None], in which case the zapping is reverted. The latter is useful - when the caller only wants to know the floor without zapping. *) - let zap_to_floor_morphvar obj mv ~commit = - let log_, lower = zap_to_floor_morphvar_aux obj mv in - (match commit with - | None -> undo_changes log_ - | Some log -> log := append_changes !log log_); - lower - - let zap_to_floor : type a r. a C.obj -> (a, allowed * r) mode -> log:_ -> a = - fun obj m ~log -> - match m with - | Amode a -> a - | Amodevar mv -> zap_to_floor_morphvar obj mv ~commit:log - | Amodejoin (a, mvs) -> - List.fold_left - (fun acc mv -> - C.join obj acc (zap_to_floor_morphvar obj mv ~commit:log)) - a mvs - let get_conservative_ceil : type a l r. a C.obj -> (a, l * r) mode -> a = fun obj m -> match m with @@ -629,6 +566,67 @@ module Solver_mono (C : Lattices_mono) = struct (* Due to our biased implementation, the ceil is precise. *) let get_ceil = get_conservative_ceil + let zap_to_ceil : type a l. a C.obj -> (a, l * allowed) mode -> log:_ -> a = + fun obj m ~log -> + let ceil = get_ceil obj m in + assert (submode obj (Amode ceil) m ~log |> Result.is_ok); + ceil + + (** Zap [mv] to its lower bound. Returns the [log] of the zapping, in + case the caller are only interested in the lower bound and wants to + reverse the zapping. + + As mentioned in [var], [mlower mv] is not precise; to get the precise + lower bound of [mv], we call [submode mv (mlower mv)]. This will propagate + to all its children, which might fail because some children's lower bound + [a] is more up-to-date than [mv]. In that case, we call [submode mv a]. We + repeat this process until no failure, and we will get the precise lower + bound. + + The loop is guaranteed to terminate, because for each iteration our + guessed lower bound is strictly higher; and all lattices are finite. + *) + let zap_to_floor_morphvar_aux (type a r) (obj : a C.obj) + (mv : (a, allowed * r) morphvar) = + let rec loop lower = + let log = ref empty_changes in + let r = submode_mvc ~log:(Some log) obj mv lower in + match r with + | Ok () -> !log, lower + | Error a -> + undo_changes !log; + loop (C.join obj a lower) + in + loop (mlower obj mv) + + (** Zaps a morphvar to its floor and returns the floor. [commit] could be + [Some log], in which case the zapping is appended to [log]; it could also + be [None], in which case the zapping is reverted. The latter is useful + when the caller only wants to know the floor without zapping. *) + let zap_to_floor_morphvar obj mv ~commit = + let log_, lower = zap_to_floor_morphvar_aux obj mv in + (match commit with + | None -> undo_changes log_ + | Some log -> log := append_changes !log log_); + lower + + let zap_to_floor : type a r. a C.obj -> (a, allowed * r) mode -> log:_ -> a = + fun obj m ~log -> + match m with + | Amode a -> a + | Amodevar mv -> zap_to_floor_morphvar obj mv ~commit:log + | Amodejoin (a, mvs) -> + let floor = + List.fold_left + (fun acc mv -> + C.join obj acc (zap_to_floor_morphvar obj mv ~commit:None)) + a mvs + in + List.iter + (fun mv -> assert (submode_mvc obj mv floor ~log |> Result.is_ok)) + mvs; + floor + let get_floor : type a r. a C.obj -> (a, allowed * r) mode -> a = fun obj m -> match m with diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index 8318a98be99..c35f6447d9c 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -444,7 +444,7 @@ let check_tail_call_local_returning loc env ap_mode {region_mode; _} = let meet_regional mode = let mode = Value.disallow_left mode in - Value.meet [mode; (Value.max_with (Comonadic Areality) Regionality.regional)] + Value.meet_with (Comonadic Areality) Regionality.Const.Regional mode let mode_default mode = { position = RNontail; @@ -6527,9 +6527,7 @@ and type_ident env ?(recarg=Rejected) lid = (* if the locality of returned value of the primitive is poly we then register allocation for further optimization *) | (Prim_poly, _), Some mode -> - register_allocation_mode - (Alloc.meet [Alloc.max_with (Comonadic Areality) mode; - Alloc.max_with (Comonadic Linearity) Linearity.many]) + register_allocation_mode (Alloc.max_with (Comonadic Areality) mode) | _ -> () end; ty, Id_prim (Option.map Locality.disallow_right mode, sort) From f8915e078b179f1171ce103813ffbaf2b7a8044f Mon Sep 17 00:00:00 2001 From: Liam Stevenson Date: Fri, 30 Aug 2024 11:22:13 -0400 Subject: [PATCH 07/76] Share `transl_modalities` code with `transl_modifiers` and `transl_modes` (#2925) * Subsume transl_modalities into Typemode * Modify error message for unrecognized modifier and add jkind tests * Fix formatting * Add jkind_axis and refactor typemodifier into typemode * Reformat * some edits --------- Co-authored-by: Zesen Qian --- ocaml/dune | 4 +- ocaml/otherlibs/dynlink/dune | 15 +- .../testsuite/tests/typing-layouts/annots.ml | 32 +++ ocaml/testsuite/tests/typing-modes/modes.ml | 6 +- ocaml/typing/.ocamlformat-enable | 4 +- ocaml/typing/jkind.ml | 23 +- ocaml/typing/jkind.mli | 8 +- ocaml/typing/jkind_axis.ml | 225 ++++++++++++++++++ ocaml/typing/jkind_axis.mli | 111 +++++++++ ocaml/typing/jkind_types.ml | 103 +------- ocaml/typing/jkind_types.mli | 43 +--- ocaml/typing/mode.ml | 2 + ocaml/typing/mode_intf.mli | 2 + ocaml/typing/typemode.ml | 170 +++++++++++-- ocaml/typing/typemode.mli | 5 + ocaml/typing/typemodifier.ml | 206 ---------------- ocaml/typing/typemodifier.mli | 28 --- 17 files changed, 564 insertions(+), 423 deletions(-) create mode 100644 ocaml/typing/jkind_axis.ml create mode 100644 ocaml/typing/jkind_axis.mli delete mode 100644 ocaml/typing/typemodifier.ml delete mode 100644 ocaml/typing/typemodifier.mli diff --git a/ocaml/dune b/ocaml/dune index e127e72a400..7cc4ada7b67 100644 --- a/ocaml/dune +++ b/ocaml/dune @@ -108,7 +108,7 @@ typedtree printtyped ctype printtyp includeclass mtype envaux includecore tast_iterator tast_mapper signature_group cmt_format cms_format untypeast includemod includemod_errorprinter - typemode typemodifier typetexp patterns printpat parmatch stypes typedecl typeopt + typemode jkind_axis typetexp patterns printpat parmatch stypes typedecl typeopt value_rec_check typecore solver_intf solver mode_intf mode uniqueness_analysis typeclass typemod typedecl_variance typedecl_properties typedecl_separability cmt2annot @@ -334,7 +334,7 @@ (untypeast.mli as compiler-libs/untypeast.mli) (includemod.mli as compiler-libs/includemod.mli) (typemode.mli as compiler-libs/typemode.mli) - (typemodifier.mli as compiler-libs/typemodifier.mli) + (jkind_axis.mli as compiler-libs/jkind_axis.mli) (typetexp.mli as compiler-libs/typetexp.mli) (printpat.mli as compiler-libs/printpat.mli) (parmatch.mli as compiler-libs/parmatch.mli) diff --git a/ocaml/otherlibs/dynlink/dune b/ocaml/otherlibs/dynlink/dune index 65a9903e9c7..f97163b7723 100644 --- a/ocaml/otherlibs/dynlink/dune +++ b/ocaml/otherlibs/dynlink/dune @@ -97,7 +97,8 @@ zero_alloc types oprint - typemodifier + jkind_axis + typemode jkind value_rec_types btype @@ -196,13 +197,14 @@ (copy_files ../../typing/jkind.ml) (copy_files ../../typing/jkind_intf.ml) (copy_files ../../typing/jkind_types.ml) -(copy_files ../../typing/typemodifier.ml) +(copy_files ../../typing/jkind_axis.ml) (copy_files ../../typing/oprint.ml) (copy_files ../../typing/primitive.ml) (copy_files ../../typing/shape.ml) (copy_files ../../typing/solver.ml) (copy_files ../../typing/shape_reduce.ml) (copy_files ../../typing/mode.ml) +(copy_files ../../typing/typemode.ml) (copy_files ../../typing/zero_alloc.ml) (copy_files ../../typing/types.ml) (copy_files ../../typing/btype.ml) @@ -268,13 +270,14 @@ (copy_files ../../typing/jkind.mli) (copy_files ../../typing/jkind_intf.mli) (copy_files ../../typing/jkind_types.mli) -(copy_files ../../typing/typemodifier.mli) +(copy_files ../../typing/jkind_axis.mli) (copy_files ../../typing/oprint.mli) (copy_files ../../typing/primitive.mli) (copy_files ../../typing/shape.mli) (copy_files ../../typing/solver.mli) (copy_files ../../typing/shape_reduce.mli) (copy_files ../../typing/mode.mli) +(copy_files ../../typing/typemode.mli) (copy_files ../../typing/zero_alloc.mli) (copy_files ../../typing/types.mli) (copy_files ../../typing/btype.mli) @@ -393,7 +396,8 @@ .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Attr_helper.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Primitive.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Oprint.cmo - .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Typemodifier.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Jkind_axis.cmo + .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Typemode.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Jkind.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Btype.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Subst.cmo @@ -479,7 +483,8 @@ .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Attr_helper.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Primitive.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Oprint.cmx - .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Typemodifier.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Jkind_axis.cmx + .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Typemode.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Jkind.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Btype.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Subst.cmx diff --git a/ocaml/testsuite/tests/typing-layouts/annots.ml b/ocaml/testsuite/tests/typing-layouts/annots.ml index a4258127631..89717d73267 100644 --- a/ocaml/testsuite/tests/typing-layouts/annots.ml +++ b/ocaml/testsuite/tests/typing-layouts/annots.ml @@ -176,6 +176,38 @@ Line 1, characters 28-34: Error: The uniqueness axis has already been specified. |}] +type t : value mod foo +[%%expect {| +Line 1, characters 19-22: +1 | type t : value mod foo + ^^^ +Error: Unrecognized modifier foo. +|}] + +type t : value mod global shared bar +[%%expect {| +Line 1, characters 33-36: +1 | type t : value mod global shared bar + ^^^ +Error: Unrecognized modifier bar. +|}] + +type t : value mod foobar unique many +[%%expect {| +Line 1, characters 19-25: +1 | type t : value mod foobar unique many + ^^^^^^ +Error: Unrecognized modifier foobar. +|}] + +type t : value mod non_null external_ fizzbuzz global +[%%expect {| +Line 1, characters 38-46: +1 | type t : value mod non_null external_ fizzbuzz global + ^^^^^^^^ +Error: Unrecognized modifier fizzbuzz. +|}] + (***************************************) (* Test 1: annotation on type variable *) diff --git a/ocaml/testsuite/tests/typing-modes/modes.ml b/ocaml/testsuite/tests/typing-modes/modes.ml index 3f94858ae14..05db9274c4e 100644 --- a/ocaml/testsuite/tests/typing-modes/modes.ml +++ b/ocaml/testsuite/tests/typing-modes/modes.ml @@ -53,7 +53,7 @@ let foo @ foo = "hello" Line 1, characters 10-13: 1 | let foo @ foo = "hello" ^^^ -Error: Unrecognized mode name foo. +Error: Unrecognized mode foo. |}] let foo () = @@ -184,7 +184,7 @@ type r = local_ string @ foo -> string Line 1, characters 25-28: 1 | type r = local_ string @ foo -> string ^^^ -Error: Unrecognized mode name foo. +Error: Unrecognized mode foo. |}] type r = local_ string @ local -> string @@ -355,7 +355,7 @@ let foo () = Line 2, characters 25-28: 2 | let bar @ unique local foo = () in ^^^ -Error: Unrecognized mode name foo. +Error: Unrecognized mode foo. |}] let foo () = diff --git a/ocaml/typing/.ocamlformat-enable b/ocaml/typing/.ocamlformat-enable index d1677b95363..27b8be84a2f 100644 --- a/ocaml/typing/.ocamlformat-enable +++ b/ocaml/typing/.ocamlformat-enable @@ -13,5 +13,5 @@ solver.ml solver.mli typemode.mli typemode.ml -typemodifier.mli -typemodifier.ml +jkind_axis.mli +jkind_axis.ml diff --git a/ocaml/typing/jkind.ml b/ocaml/typing/jkind.ml index b9364973ccb..03f39495705 100644 --- a/ocaml/typing/jkind.ml +++ b/ocaml/typing/jkind.ml @@ -125,8 +125,8 @@ module Layout = struct end end -module Externality = Jkind_types.Externality -module Nullability = Jkind_types.Nullability +module Externality = Jkind_axis.Externality +module Nullability = Jkind_axis.Nullability module Modes = struct include Alloc.Const @@ -605,20 +605,25 @@ module Const = struct | Mod (jkind, modifiers) -> let base = of_user_written_annotation_unchecked_level jkind in (* for each mode, lower the corresponding modal bound to be that mode *) - let parsed_modifiers = Typemodifier.transl_modifier_annots modifiers in + let parsed_modifiers = Typemode.transl_modifier_annots modifiers in + let parsed_modes : Alloc.Const.Option.t = + { areality = parsed_modifiers.locality; + linearity = parsed_modifiers.linearity; + uniqueness = parsed_modifiers.uniqueness; + portability = parsed_modifiers.portability; + contention = parsed_modifiers.contention + } + in { layout = base.layout; modes_upper_bounds = Alloc.Const.meet base.modes_upper_bounds - (Alloc.Const.Option.value ~default:Alloc.Const.max - parsed_modifiers.modal_upper_bounds); + (Alloc.Const.Option.value ~default:Alloc.Const.max parsed_modes); nullability_upper_bound = Nullability.meet base.nullability_upper_bound - (Option.value ~default:Nullability.max - parsed_modifiers.nullability_upper_bound); + (Option.value ~default:Nullability.max parsed_modifiers.nullability); externality_upper_bound = Externality.meet base.externality_upper_bound - (Option.value ~default:Externality.max - parsed_modifiers.externality_upper_bound) + (Option.value ~default:Externality.max parsed_modifiers.externality) } | Default | With _ | Kind_of _ -> Misc.fatal_error "XXX unimplemented" diff --git a/ocaml/typing/jkind.mli b/ocaml/typing/jkind.mli index cb58e74a65a..7345dea964c 100644 --- a/ocaml/typing/jkind.mli +++ b/ocaml/typing/jkind.mli @@ -42,20 +42,20 @@ https://github.com/goldfirere/flambda-backend/commit/d802597fbdaaa850e1ed9209a1305c5dcdf71e17 first, which was reisenberg's attempt to do so. *) module Externality : sig - type t = Jkind_types.Externality.t = + type t = Jkind_axis.Externality.t = | External (* not managed by the garbage collector *) | External64 (* not managed by the garbage collector on 64-bit systems *) | Internal (* managed by the garbage collector *) - include module type of Jkind_types.Externality with type t := t + include module type of Jkind_axis.Externality with type t := t end module Nullability : sig - type t = Jkind_types.Nullability.t = + type t = Jkind_axis.Nullability.t = | Non_null (* proven to not have NULL values *) | Maybe_null (* may have NULL values *) - include module type of Jkind_types.Nullability with type t := t + include module type of Jkind_axis.Nullability with type t := t end module Sort : Jkind_intf.Sort with type const = Jkind_types.Sort.const diff --git a/ocaml/typing/jkind_axis.ml b/ocaml/typing/jkind_axis.ml new file mode 100644 index 00000000000..12454da12c9 --- /dev/null +++ b/ocaml/typing/jkind_axis.ml @@ -0,0 +1,225 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Liam Stevenson, Jane Street, New York *) +(* *) +(* Copyright 2021 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Externality = struct + type t = + | External + | External64 + | Internal + + let max = Internal + + let min = External + + let equal e1 e2 = + match e1, e2 with + | External, External -> true + | External64, External64 -> true + | Internal, Internal -> true + | (External | External64 | Internal), _ -> false + + let less_or_equal t1 t2 : Misc.Le_result.t = + match t1, t2 with + | External, External -> Equal + | External, (External64 | Internal) -> Less + | External64, External -> Not_le + | External64, External64 -> Equal + | External64, Internal -> Less + | Internal, (External | External64) -> Not_le + | Internal, Internal -> Equal + + let le t1 t2 = Misc.Le_result.is_le (less_or_equal t1 t2) + + let meet t1 t2 = + match t1, t2 with + | External, (External | External64 | Internal) + | (External64 | Internal), External -> + External + | External64, (External64 | Internal) | Internal, External64 -> External64 + | Internal, Internal -> Internal + + let print ppf = function + | External -> Format.fprintf ppf "external_" + | External64 -> Format.fprintf ppf "external64" + | Internal -> Format.fprintf ppf "internal" +end + +module Nullability = struct + type t = + | Non_null + | Maybe_null + + let max = Maybe_null + + let min = Non_null + + let equal n1 n2 = + match n1, n2 with + | Non_null, Non_null -> true + | Maybe_null, Maybe_null -> true + | (Non_null | Maybe_null), _ -> false + + let less_or_equal n1 n2 : Misc.Le_result.t = + match n1, n2 with + | Non_null, Non_null -> Equal + | Non_null, Maybe_null -> Less + | Maybe_null, Non_null -> Not_le + | Maybe_null, Maybe_null -> Equal + + let le n1 n2 = Misc.Le_result.is_le (less_or_equal n1 n2) + + let meet n1 n2 = + match n1, n2 with + | Non_null, (Non_null | Maybe_null) | Maybe_null, Non_null -> Non_null + | Maybe_null, Maybe_null -> Maybe_null + + let print ppf = function + | Non_null -> Format.fprintf ppf "non_null" + | Maybe_null -> Format.fprintf ppf "maybe_null" +end + +module type Axis_s = sig + type t + + val max : t + + val min : t + + val equal : t -> t -> bool + + val less_or_equal : t -> t -> Misc.Le_result.t + + val le : t -> t -> bool + + val meet : t -> t -> t + + val print : Format.formatter -> t -> unit +end + +module Axis = struct + module Modal = struct + type 'a t = + | Locality : Mode.Locality.Const.t t + | Linearity : Mode.Linearity.Const.t t + | Uniqueness : Mode.Uniqueness.Const.t t + | Portability : Mode.Portability.Const.t t + | Contention : Mode.Contention.Const.t t + end + + module Nonmodal = struct + type 'a t = + | Externality : Externality.t t + | Nullability : Nullability.t t + end + + type 'a t = + | Modal of 'a Modal.t + | Nonmodal of 'a Nonmodal.t + + type packed = Pack : 'a t -> packed + + module Accent_lattice (M : Mode_intf.Lattice) = struct + (* A functor to add some convenient functions to modal axes *) + include M + + let less_or_equal a b : Misc.Le_result.t = + match le a b, le b a with + | true, true -> Equal + | true, false -> Less + | false, _ -> Not_le + + let equal a b = Misc.Le_result.is_equal (less_or_equal a b) + end + + let get (type a) : a t -> (module Axis_s with type t = a) = function + | Modal Locality -> + (module Accent_lattice (Mode.Locality.Const) : Axis_s with type t = a) + | Modal Linearity -> + (module Accent_lattice (Mode.Linearity.Const) : Axis_s with type t = a) + | Modal Uniqueness -> + (module Accent_lattice (Mode.Uniqueness.Const) : Axis_s with type t = a) + | Modal Portability -> + (module Accent_lattice (Mode.Portability.Const) : Axis_s with type t = a) + | Modal Contention -> + (module Accent_lattice (Mode.Contention.Const) : Axis_s with type t = a) + | Nonmodal Externality -> (module Externality : Axis_s with type t = a) + | Nonmodal Nullability -> (module Nullability : Axis_s with type t = a) + + let all = + [ Pack (Modal Locality); + Pack (Modal Linearity); + Pack (Modal Uniqueness); + Pack (Modal Portability); + Pack (Modal Contention); + Pack (Nonmodal Externality); + Pack (Nonmodal Nullability) ] + + let name (type a) : a t -> string = function + | Modal Locality -> "locality" + | Modal Linearity -> "linearity" + | Modal Uniqueness -> "uniqueness" + | Modal Portability -> "portability" + | Modal Contention -> "contention" + | Nonmodal Externality -> "externality" + | Nonmodal Nullability -> "nullability" +end + +(* Sadly this needs to be functorized since we don't have higher-kinded types *) +module Axis_collection (T : Misc.T1) = struct + type t = + { locality : Mode.Locality.Const.t T.t; + linearity : Mode.Linearity.Const.t T.t; + uniqueness : Mode.Uniqueness.Const.t T.t; + portability : Mode.Portability.Const.t T.t; + contention : Mode.Contention.Const.t T.t; + externality : Externality.t T.t; + nullability : Nullability.t T.t + } + + let get (type a) ~(axis : a Axis.t) values : a T.t = + match axis with + | Modal Locality -> values.locality + | Modal Linearity -> values.linearity + | Modal Uniqueness -> values.uniqueness + | Modal Portability -> values.portability + | Modal Contention -> values.contention + | Nonmodal Externality -> values.externality + | Nonmodal Nullability -> values.nullability + + let set (type a) ~(axis : a Axis.t) values (value : a T.t) = + match axis with + | Modal Locality -> { values with locality = value } + | Modal Linearity -> { values with linearity = value } + | Modal Uniqueness -> { values with uniqueness = value } + | Modal Portability -> { values with portability = value } + | Modal Contention -> { values with contention = value } + | Nonmodal Externality -> { values with externality = value } + | Nonmodal Nullability -> { values with nullability = value } + + (* Since we don't have polymorphic parameters, use a record to pass the polymorphic + function *) + module Create_f = struct + type t = { f : 'a. axis:'a Axis.t -> 'a T.t } + end + + let create ({ f } : Create_f.t) = + { locality = f ~axis:Axis.(Modal Locality); + linearity = f ~axis:Axis.(Modal Linearity); + uniqueness = f ~axis:Axis.(Modal Uniqueness); + portability = f ~axis:Axis.(Modal Portability); + contention = f ~axis:Axis.(Modal Contention); + externality = f ~axis:Axis.(Nonmodal Externality); + nullability = f ~axis:Axis.(Nonmodal Nullability) + } +end diff --git a/ocaml/typing/jkind_axis.mli b/ocaml/typing/jkind_axis.mli new file mode 100644 index 00000000000..69c93547333 --- /dev/null +++ b/ocaml/typing/jkind_axis.mli @@ -0,0 +1,111 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Liam Stevenson, Jane Street, New York *) +(* *) +(* Copyright 2021 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** The common interface for jkind axes *) +module type Axis_s = sig + type t + + val max : t + + val min : t + + val equal : t -> t -> bool + + val less_or_equal : t -> t -> Misc.Le_result.t + + val le : t -> t -> bool + + val meet : t -> t -> t + + val print : Format.formatter -> t -> unit +end + +(** The jkind axis of Externality *) +module Externality : sig + type t = + | External + | External64 + | Internal + + include Axis_s with type t := t +end + +(** The jkind axis of nullability *) +module Nullability : sig + type t = + | Non_null + | Maybe_null + + include Axis_s with type t := t +end + +module Axis : sig + (* CR zqian: remove this and use [Mode.Alloc.axis] instead *) + module Modal : sig + type 'a t = + | Locality : Mode.Locality.Const.t t + | Linearity : Mode.Linearity.Const.t t + | Uniqueness : Mode.Uniqueness.Const.t t + | Portability : Mode.Portability.Const.t t + | Contention : Mode.Contention.Const.t t + end + + module Nonmodal : sig + type 'a t = + | Externality : Externality.t t + | Nullability : Nullability.t t + end + + (** Represents an axis of a jkind *) + type 'a t = + | Modal of 'a Modal.t + | Nonmodal of 'a Nonmodal.t + + type packed = Pack : 'a t -> packed + + (* CR zqian: push ['a t] into the module to avoid first-class module. *) + + (** Given a jkind axis, get its interface *) + val get : 'a t -> (module Axis_s with type t = 'a) + + val all : packed list + + val name : _ t -> string +end + +(** A collection with one item for each jkind axis. + [T] parametizes what element is being held for each axis. *) +module Axis_collection (T : Misc.T1) : sig + type t = + { locality : Mode.Locality.Const.t T.t; + linearity : Mode.Linearity.Const.t T.t; + uniqueness : Mode.Uniqueness.Const.t T.t; + portability : Mode.Portability.Const.t T.t; + contention : Mode.Contention.Const.t T.t; + externality : Externality.t T.t; + nullability : Nullability.t T.t + } + + val get : axis:'a Axis.t -> t -> 'a T.t + + val set : axis:'a Axis.t -> t -> 'a T.t -> t + + module Create_f : sig + (** This record type is used to pass a polymorphic function to [create] *) + type t = { f : 'a. axis:'a Axis.t -> 'a T.t } + end + + (** Create an axis collection by applying the function on each axis *) + val create : Create_f.t -> t +end diff --git a/ocaml/typing/jkind_types.ml b/ocaml/typing/jkind_types.ml index 4186888eb0d..3646b18f9f4 100644 --- a/ocaml/typing/jkind_types.ml +++ b/ocaml/typing/jkind_types.ml @@ -350,109 +350,14 @@ module Layout = struct type t = Sort.t layout end -module type Axis = sig - type t - - val max : t - - val min : t - - val equal : t -> t -> bool - - val less_or_equal : t -> t -> Misc.Le_result.t - - val le : t -> t -> bool - - val meet : t -> t -> t - - val print : Format.formatter -> t -> unit -end - -module Externality = struct - type t = - | External - | External64 - | Internal - - let max = Internal - - let min = External - - let equal e1 e2 = - match e1, e2 with - | External, External -> true - | External64, External64 -> true - | Internal, Internal -> true - | (External | External64 | Internal), _ -> false - - let less_or_equal t1 t2 : Misc.Le_result.t = - match t1, t2 with - | External, External -> Equal - | External, (External64 | Internal) -> Less - | External64, External -> Not_le - | External64, External64 -> Equal - | External64, Internal -> Less - | Internal, (External | External64) -> Not_le - | Internal, Internal -> Equal - - let le t1 t2 = Misc.Le_result.is_le (less_or_equal t1 t2) - - let meet t1 t2 = - match t1, t2 with - | External, (External | External64 | Internal) - | (External64 | Internal), External -> - External - | External64, (External64 | Internal) | Internal, External64 -> External64 - | Internal, Internal -> Internal - - let print ppf = function - | External -> Format.fprintf ppf "external_" - | External64 -> Format.fprintf ppf "external64" - | Internal -> Format.fprintf ppf "internal" -end - -module Nullability = struct - type t = - | Non_null - | Maybe_null - - let max = Maybe_null - - let min = Non_null - - let equal n1 n2 = - match n1, n2 with - | Non_null, Non_null -> true - | Maybe_null, Maybe_null -> true - | (Non_null | Maybe_null), _ -> false - - let less_or_equal n1 n2 : Misc.Le_result.t = - match n1, n2 with - | Non_null, Non_null -> Equal - | Non_null, Maybe_null -> Less - | Maybe_null, Non_null -> Not_le - | Maybe_null, Maybe_null -> Equal - - let le n1 n2 = Misc.Le_result.is_le (less_or_equal n1 n2) - - let meet n1 n2 = - match n1, n2 with - | Non_null, (Non_null | Maybe_null) | Maybe_null, Non_null -> Non_null - | Maybe_null, Maybe_null -> Maybe_null - - let print ppf = function - | Non_null -> Format.fprintf ppf "non_null" - | Maybe_null -> Format.fprintf ppf "maybe_null" -end - module Modes = Mode.Alloc.Const module Jkind_desc = struct type 'type_expr t = { layout : Layout.t; modes_upper_bounds : Modes.t; - externality_upper_bound : Externality.t; - nullability_upper_bound : Nullability.t + externality_upper_bound : Jkind_axis.Externality.t; + nullability_upper_bound : Jkind_axis.Nullability.t } end @@ -482,8 +387,8 @@ module Const = struct type 'type_expr t = { layout : Layout.Const.t; modes_upper_bounds : Modes.t; - externality_upper_bound : Externality.t; - nullability_upper_bound : Nullability.t + externality_upper_bound : Jkind_axis.Externality.t; + nullability_upper_bound : Jkind_axis.Nullability.t } end diff --git a/ocaml/typing/jkind_types.mli b/ocaml/typing/jkind_types.mli index 7c29d0d2457..54534960cf1 100644 --- a/ocaml/typing/jkind_types.mli +++ b/ocaml/typing/jkind_types.mli @@ -107,49 +107,14 @@ module Layout : sig type t = Sort.t layout end -module type Axis = sig - type t - - val max : t - - val min : t - - val equal : t -> t -> bool - - val less_or_equal : t -> t -> Misc.Le_result.t - - val le : t -> t -> bool - - val meet : t -> t -> t - - val print : Format.formatter -> t -> unit -end - -module Externality : sig - type t = - | External - | External64 - | Internal - - include Axis with type t := t -end - -module Nullability : sig - type t = - | Non_null - | Maybe_null - - include Axis with type t := t -end - module Modes = Mode.Alloc.Const module Jkind_desc : sig type 'type_expr t = { layout : Layout.t; modes_upper_bounds : Modes.t; - externality_upper_bound : Externality.t; - nullability_upper_bound : Nullability.t + externality_upper_bound : Jkind_axis.Externality.t; + nullability_upper_bound : Jkind_axis.Nullability.t } end @@ -174,8 +139,8 @@ module Const : sig type 'type_expr t = { layout : Layout.Const.t; modes_upper_bounds : Modes.t; - externality_upper_bound : Externality.t; - nullability_upper_bound : Nullability.t + externality_upper_bound : Jkind_axis.Externality.t; + nullability_upper_bound : Jkind_axis.Nullability.t } end diff --git a/ocaml/typing/mode.ml b/ocaml/typing/mode.ml index baf6dbb5865..5e7927cf0e3 100644 --- a/ocaml/typing/mode.ml +++ b/ocaml/typing/mode.ml @@ -2137,6 +2137,8 @@ module Const = struct Alloc.Const.t) : Value.Const.t = let areality = C.locality_as_regionality areality in { areality; linearity; portability; uniqueness; contention } + + let locality_as_regionality = C.locality_as_regionality end let alloc_as_value m = diff --git a/ocaml/typing/mode_intf.mli b/ocaml/typing/mode_intf.mli index 8b2459aac29..857e6f90c40 100644 --- a/ocaml/typing/mode_intf.mli +++ b/ocaml/typing/mode_intf.mli @@ -428,6 +428,8 @@ module type S = sig module Const : sig val alloc_as_value : Alloc.Const.t -> Value.Const.t + + val locality_as_regionality : Locality.Const.t -> Regionality.Const.t end (** Converts regional to local, identity otherwise *) diff --git a/ocaml/typing/typemode.ml b/ocaml/typing/typemode.ml index 1a440e83230..3af32f3fdda 100644 --- a/ocaml/typing/typemode.ml +++ b/ocaml/typing/typemode.ml @@ -1,12 +1,122 @@ open Location open Mode +open Jkind_axis -type error = Unrecognized_modality of string +(* CR zqian: kind modifier can be either a modaity or externality/nullability. + I.e., mode-like modifiers are just modalities and should be represented as + such. Therefore, [transl_modalities] (not dealing with + externality/nullability) will stay in this file, while [transl_modifiers] + should go into [typekind.ml] and calls [transl_modalities]. *) + +type modal = private | + +type maybe_nonmodal = private | + +type 'm annot_type = + | Modifier : maybe_nonmodal annot_type + | Mode : modal annot_type + | Modality : modal annot_type + +type error = + | Duplicated_axis : _ Axis.t -> error + | Unrecognized_modifier : _ annot_type * string -> error exception Error of Location.t * error -let transl_mode_annots modes = - Typemodifier.transl_mode_annots ~required_mode_maturity:Stable modes +module Axis_pair = struct + type 'm t = + | Modal_axis_pair : 'a Axis.Modal.t * 'a -> modal t + | Any_axis_pair : 'a Axis.t * 'a -> maybe_nonmodal t + + let of_string s = + let open Mode in + match s with + | "local" -> Any_axis_pair (Modal Locality, Locality.Const.Local) + | "global" -> Any_axis_pair (Modal Locality, Locality.Const.Global) + | "unique" -> Any_axis_pair (Modal Uniqueness, Uniqueness.Const.Unique) + | "shared" -> Any_axis_pair (Modal Uniqueness, Uniqueness.Const.Shared) + | "once" -> Any_axis_pair (Modal Linearity, Linearity.Const.Once) + | "many" -> Any_axis_pair (Modal Linearity, Linearity.Const.Many) + | "nonportable" -> + Any_axis_pair (Modal Portability, Portability.Const.Nonportable) + | "portable" -> Any_axis_pair (Modal Portability, Portability.Const.Portable) + | "contended" -> Any_axis_pair (Modal Contention, Contention.Const.Contended) + | "uncontended" -> + Any_axis_pair (Modal Contention, Contention.Const.Uncontended) + | "maybe_null" -> + Any_axis_pair (Nonmodal Nullability, Nullability.Maybe_null) + | "non_null" -> Any_axis_pair (Nonmodal Nullability, Nullability.Non_null) + | "internal" -> Any_axis_pair (Nonmodal Externality, Externality.Internal) + | "external64" -> + Any_axis_pair (Nonmodal Externality, Externality.External64) + | "external_" -> Any_axis_pair (Nonmodal Externality, Externality.External) + | _ -> raise Not_found +end + +let transl_annot (type m) ~(annot_type : m annot_type) ~required_mode_maturity + annot : m Axis_pair.t = + Option.iter + (fun maturity -> + Jane_syntax_parsing.assert_extension_enabled ~loc:annot.loc Mode maturity) + required_mode_maturity; + match Axis_pair.of_string annot.txt, annot_type with + | Any_axis_pair (Nonmodal _, _), (Mode | Modality) | (exception Not_found) -> + raise (Error (annot.loc, Unrecognized_modifier (annot_type, annot.txt))) + | Any_axis_pair (Modal axis, mode), Mode -> Modal_axis_pair (axis, mode) + | Any_axis_pair (Modal axis, mode), Modality -> Modal_axis_pair (axis, mode) + | pair, Modifier -> pair + +let unpack_mode_annot { txt = Parsetree.Mode s; loc } = { txt = s; loc } + +module Opt_axis_collection = Axis_collection (Option) + +let transl_modifier_annots annots = + let step modifiers_so_far annot = + let (Any_axis_pair (type a) ((axis, mode) : a Axis.t * a)) = + transl_annot ~annot_type:Modifier ~required_mode_maturity:None + @@ unpack_mode_annot annot + in + let (module A : Axis_s with type t = a) = Axis.get axis in + let is_top = A.le A.max mode in + if is_top + then + (* CR layouts v2.8: This warning is disabled for now because transl_type_decl + results in 3 calls to transl_annots per user-written annotation. This results + in the warning being reported 3 times. *) + (* Location.prerr_warning new_raw.loc (Warnings.Mod_by_top new_raw.txt) *) + (); + let is_dup = + Option.is_some (Opt_axis_collection.get ~axis modifiers_so_far) + in + if is_dup then raise (Error (annot.loc, Duplicated_axis axis)); + Opt_axis_collection.set ~axis modifiers_so_far (Some mode) + in + let empty_modifiers = + Opt_axis_collection.create { f = (fun ~axis:_ -> None) } + in + List.fold_left step empty_modifiers annots + +let transl_mode_annots annots : Alloc.Const.Option.t = + let step modifiers_so_far annot = + let (Modal_axis_pair (type a) ((axis, mode) : a Axis.Modal.t * a)) = + transl_annot ~annot_type:Mode ~required_mode_maturity:(Some Stable) + @@ unpack_mode_annot annot + in + let axis = Axis.Modal axis in + if Option.is_some (Opt_axis_collection.get ~axis modifiers_so_far) + then raise (Error (annot.loc, Duplicated_axis axis)); + Opt_axis_collection.set ~axis modifiers_so_far (Some mode) + in + let empty_modifiers = + Opt_axis_collection.create { f = (fun ~axis:_ -> None) } + in + let modes = List.fold_left step empty_modifiers annots in + { areality = modes.locality; + linearity = modes.linearity; + uniqueness = modes.uniqueness; + portability = modes.portability; + contention = modes.contention + } let untransl_mode_annots ~loc (modes : Mode.Alloc.Const.Option.t) = let print_to_string_opt print a = Option.map (Format.asprintf "%a" print) a in @@ -27,26 +137,23 @@ let untransl_mode_annots ~loc (modes : Mode.Alloc.Const.Option.t) = (fun x -> Option.map (fun s -> { txt = Parsetree.Mode s; loc }) x) [areality; uniqueness; linearity; portability; contention] -let transl_modality ~maturity m : Modality.t = - let { txt; loc } = m in - let (Parsetree.Modality s) = txt in - Jane_syntax_parsing.assert_extension_enabled ~loc Mode maturity; - match s with - | "global" -> Atom (Comonadic Areality, Meet_with Regionality.Const.Global) - | "local" -> Atom (Comonadic Areality, Meet_with Regionality.Const.Local) - | "many" -> Atom (Comonadic Linearity, Meet_with Linearity.Const.Many) - | "once" -> Atom (Comonadic Linearity, Meet_with Linearity.Const.Once) - | "shared" -> Atom (Monadic Uniqueness, Join_with Uniqueness.Const.Shared) - | "unique" -> Atom (Monadic Uniqueness, Join_with Uniqueness.Const.Unique) - | "portable" -> - Atom (Comonadic Portability, Meet_with Portability.Const.Portable) - | "nonportable" -> - Atom (Comonadic Portability, Meet_with Portability.Const.Nonportable) - | "contended" -> - Atom (Monadic Contention, Join_with Contention.Const.Contended) - | "uncontended" -> - Atom (Monadic Contention, Join_with Contention.Const.Uncontended) - | s -> raise (Error (loc, Unrecognized_modality s)) +let transl_modality ~maturity { txt = Parsetree.Modality modality; loc } = + let axis_pair = + transl_annot ~annot_type:Modality ~required_mode_maturity:(Some maturity) + { txt = modality; loc } + in + match axis_pair with + | Modal_axis_pair (Locality, mode) -> + Modality.Atom + (Comonadic Areality, Meet_with (Const.locality_as_regionality mode)) + | Modal_axis_pair (Linearity, mode) -> + Modality.Atom (Comonadic Linearity, Meet_with mode) + | Modal_axis_pair (Uniqueness, mode) -> + Modality.Atom (Monadic Uniqueness, Join_with mode) + | Modal_axis_pair (Portability, mode) -> + Modality.Atom (Comonadic Portability, Meet_with mode) + | Modal_axis_pair (Contention, mode) -> + Modality.Atom (Monadic Contention, Join_with mode) let untransl_modality (a : Modality.t) : Parsetree.modality loc = let s = @@ -120,10 +227,21 @@ let transl_alloc_mode modes = let opt = transl_mode_annots modes in Alloc.Const.Option.value opt ~default:Alloc.Const.legacy -open Format +(* Error reporting *) -let report_error ppf = function - | Unrecognized_modality s -> fprintf ppf "Unrecognized modality %s." s +let report_error ppf = + let open Format in + function + | Duplicated_axis axis -> + fprintf ppf "The %s axis has already been specified." (Axis.name axis) + | Unrecognized_modifier (annot_type, modifier) -> + let annot_type_str = + match annot_type with + | Modifier -> "modifier" + | Mode -> "mode" + | Modality -> "modality" + in + fprintf ppf "Unrecognized %s %s." annot_type_str modifier let () = Location.register_error_of_exn (function diff --git a/ocaml/typing/typemode.mli b/ocaml/typing/typemode.mli index 61b18438d8a..96fdd145b68 100644 --- a/ocaml/typing/typemode.mli +++ b/ocaml/typing/typemode.mli @@ -29,3 +29,8 @@ val untransl_modalities : Parsetree.attributes -> Mode.Modality.Value.Const.t -> Parsetree.modalities + +(** Interpret a list of modifiers. + A "modifier" is any keyword coming after a `mod` in a jkind *) +val transl_modifier_annots : + Parsetree.modes -> Jkind_axis.Axis_collection(Option).t diff --git a/ocaml/typing/typemodifier.ml b/ocaml/typing/typemodifier.ml deleted file mode 100644 index bb9a25c28a0..00000000000 --- a/ocaml/typing/typemodifier.ml +++ /dev/null @@ -1,206 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Liam Stevenson, Jane Street, New York *) -(* *) -(* Copyright 2024 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) -type modifiers = - { modal_upper_bounds : Mode.Alloc.Const.Option.t; - externality_upper_bound : Jkind_types.Externality.t option; - nullability_upper_bound : Jkind_types.Nullability.t option - } - -type annot_type = - | Modifier - | Mode - -type _ modal_axis = - | Areality : Mode.Locality.Const.t modal_axis - | Uniqueness : Mode.Uniqueness.Const.t modal_axis - | Linearity : Mode.Linearity.Const.t modal_axis - | Portability : Mode.Portability.Const.t modal_axis - | Contention : Mode.Contention.Const.t modal_axis - -type _ nonmodal_axis = - | Externality : Jkind_types.Externality.t nonmodal_axis - | Nullability : Jkind_types.Nullability.t nonmodal_axis - -type _ axis = - | Modal : 'a modal_axis -> 'a axis - | Nonmodal : 'a nonmodal_axis -> 'a axis - -type axis_pair = Axis_pair : 'a axis * 'a -> axis_pair - -type error = - | Duplicated_axis : _ axis -> error - | Unrecognized_modifier : annot_type * string -> error - -exception Error of Location.t * error - -module Str_map = Map.Make (String) - -let axis_name (type a) (axis : a axis) = - match axis with - | Modal Areality -> "locality" - | Modal Linearity -> "linearity" - | Modal Uniqueness -> "uniqueness" - | Modal Portability -> "portability" - | Modal Contention -> "contention" - | Nonmodal Externality -> "externality" - | Nonmodal Nullability -> "nullability" - -let modifiers = - let alist = - let open Mode in - let open Jkind_types in - [ "local", Axis_pair (Modal Areality, Locality.Const.Local); - "global", Axis_pair (Modal Areality, Locality.Const.Global); - "unique", Axis_pair (Modal Uniqueness, Uniqueness.Const.Unique); - "shared", Axis_pair (Modal Uniqueness, Uniqueness.Const.Shared); - "once", Axis_pair (Modal Linearity, Linearity.Const.Once); - "many", Axis_pair (Modal Linearity, Linearity.Const.Many); - "nonportable", Axis_pair (Modal Portability, Portability.Const.Nonportable); - "portable", Axis_pair (Modal Portability, Portability.Const.Portable); - "contended", Axis_pair (Modal Contention, Contention.Const.Contended); - "uncontended", Axis_pair (Modal Contention, Contention.Const.Uncontended); - "maybe_null", Axis_pair (Nonmodal Nullability, Nullability.Maybe_null); - "non_null", Axis_pair (Nonmodal Nullability, Nullability.Non_null); - "internal", Axis_pair (Nonmodal Externality, Externality.Internal); - "external64", Axis_pair (Nonmodal Externality, Externality.External64); - "external_", Axis_pair (Nonmodal Externality, Externality.External) ] - in - List.fold_left - (fun acc (name, axis_pair) -> Str_map.add name axis_pair acc) - Str_map.empty alist - -(* Raise an error if the user duplicated annotations along an axis, and a warning - if they used a top. The warning is only output when annot_type is Modifier *) -let check_annot (type a) ~(annot_type : annot_type) ~(axis : a axis) ~old - ~(new_ : a Location.loc) = - let is_top = - match axis, new_ with - | Modal Areality, _ -> Mode.Locality.Const.(le max new_.txt) - | Modal Linearity, _ -> Mode.Linearity.Const.(le max new_.txt) - | Modal Uniqueness, _ -> Mode.Uniqueness.Const.(le max new_.txt) - | Modal Portability, _ -> Mode.Portability.Const.(le max new_.txt) - | Modal Contention, _ -> Mode.Contention.Const.(le max new_.txt) - | Nonmodal Externality, _ -> Jkind_types.Externality.(le max new_.txt) - | Nonmodal Nullability, _ -> Jkind_types.Nullability.(le max new_.txt) - in - (match annot_type with - | Modifier -> - if is_top - then - (* CR layouts v2.8: This warning is disabled for now because transl_type_decl - results in 3 calls to transl_annots per user-written annotation. This results - in the warning being reported 3 times. *) - (* Location.prerr_warning new_raw.loc (Warnings.Mod_by_top new_raw.txt) *) - () - | Mode -> ()); - match old with - | None -> () - | Some _ -> raise (Error (new_.loc, Duplicated_axis axis)) - -let set_axis (type a) ~annot_type ~(axis : a axis) (acc : modifiers) - (modifier : a Location.loc) : modifiers = - let old : a option = - match axis with - | Modal Areality -> acc.modal_upper_bounds.areality - | Modal Uniqueness -> acc.modal_upper_bounds.uniqueness - | Modal Linearity -> acc.modal_upper_bounds.linearity - | Modal Portability -> acc.modal_upper_bounds.portability - | Modal Contention -> acc.modal_upper_bounds.contention - | Nonmodal Externality -> acc.externality_upper_bound - | Nonmodal Nullability -> acc.nullability_upper_bound - in - check_annot ~annot_type ~axis ~old ~new_:modifier; - match axis with - | Modal axis -> - let modal_upper_bounds : Mode.Alloc.Const.Option.t = - match axis with - | Areality -> { acc.modal_upper_bounds with areality = Some modifier.txt } - | Uniqueness -> - { acc.modal_upper_bounds with uniqueness = Some modifier.txt } - | Linearity -> - { acc.modal_upper_bounds with linearity = Some modifier.txt } - | Portability -> - { acc.modal_upper_bounds with portability = Some modifier.txt } - | Contention -> - { acc.modal_upper_bounds with contention = Some modifier.txt } - in - { acc with modal_upper_bounds } - | Nonmodal Externality -> - { acc with externality_upper_bound = Some modifier.txt } - | Nonmodal Nullability -> - { acc with nullability_upper_bound = Some modifier.txt } - -let transl_annots ~annot_type ~required_mode_maturity annots = - let transl_annot modifiers_so_far annot = - let ({ txt = Mode annot_txt; loc } : Parsetree.mode Location.loc) = annot in - Option.iter - (fun maturity -> - Jane_syntax_parsing.assert_extension_enabled ~loc Mode maturity) - required_mode_maturity; - let modifiers = - match Str_map.find_opt annot_txt modifiers, annot_type with - | Some (Axis_pair (Nonmodal _, _)), Mode | None, _ -> - raise (Error (loc, Unrecognized_modifier (annot_type, annot_txt))) - | Some (Axis_pair (axis, mode)), _ -> - set_axis ~annot_type ~axis modifiers_so_far { txt = mode; loc } - in - modifiers - in - let empty_modifiers = - { modal_upper_bounds = Mode.Alloc.Const.Option.none; - externality_upper_bound = None; - nullability_upper_bound = None - } - in - List.fold_left transl_annot empty_modifiers annots - -let transl_mode_annots ?required_mode_maturity annots = - let modifiers = - transl_annots ~annot_type:Mode ~required_mode_maturity annots - in - let assert_empty axis bound = - if Option.is_some bound - then - let error_message = - Format.asprintf - "Expected empty nonmodal modifiers when translating modes, but got \ - one along %s axis" - (axis_name (Nonmodal axis)) - in - Misc.fatal_error error_message - in - assert_empty Externality modifiers.externality_upper_bound; - assert_empty Nullability modifiers.nullability_upper_bound; - modifiers.modal_upper_bounds - -let transl_modifier_annots annots = - transl_annots ~annot_type:Modifier ~required_mode_maturity:None annots - -(* Error reporting *) - -let report_error ppf = - let open Format in - function - | Duplicated_axis axis -> - fprintf ppf "The %s axis has already been specified." (axis_name axis) - | Unrecognized_modifier (annot_type, modifier) -> - let annot_type_str = - match annot_type with Modifier -> "modifier" | Mode -> "mode" - in - fprintf ppf "Unrecognized %s name %s." annot_type_str modifier - -let () = - Location.register_error_of_exn (function - | Error (loc, err) -> Some (Location.error_of_printer ~loc report_error err) - | _ -> None) diff --git a/ocaml/typing/typemodifier.mli b/ocaml/typing/typemodifier.mli deleted file mode 100644 index 6c38293d290..00000000000 --- a/ocaml/typing/typemodifier.mli +++ /dev/null @@ -1,28 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Liam Stevenson, Jane Street, New York *) -(* *) -(* Copyright 2024 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) -type modifiers = - { modal_upper_bounds : Mode.Alloc.Const.Option.t; - externality_upper_bound : Jkind_types.Externality.t option; - nullability_upper_bound : Jkind_types.Nullability.t option - } - -(** Interpret a list of modes *) -val transl_mode_annots : - ?required_mode_maturity:Language_extension.maturity -> - Parsetree.modes -> - Mode.Alloc.Const.Option.t - -(** Interpret a list of modifiers. - A "modifier" is any keyword coming after a `mod` in a jkind *) -val transl_modifier_annots : Parsetree.modes -> modifiers From 944aae0cb84e6ead64686f45b01c0b5780a8db3b Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Tue, 3 Sep 2024 05:04:37 -0400 Subject: [PATCH 08/76] Backport upstream #13370 (#3005) Backport 13370 --- ocaml/runtime/gc_ctrl.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/ocaml/runtime/gc_ctrl.c b/ocaml/runtime/gc_ctrl.c index 8829e984b48..6851e5872af 100644 --- a/ocaml/runtime/gc_ctrl.c +++ b/ocaml/runtime/gc_ctrl.c @@ -106,7 +106,7 @@ CAMLprim value caml_gc_minor_words(value v) CAMLprim value caml_gc_counters(value v) { CAMLparam0 (); /* v is ignored */ - CAMLlocal1 (res); + CAMLlocal4 (minwords_, prowords_, majwords_, res); /* get a copy of these before allocating anything... */ double minwords = Caml_state->stat_minor_words @@ -116,11 +116,11 @@ CAMLprim value caml_gc_counters(value v) double majwords = Caml_state->stat_major_words + (double) Caml_state->allocated_words; - res = caml_alloc_3(0, - caml_copy_double (minwords), - caml_copy_double (prowords), - caml_copy_double (majwords)); - CAMLreturn (res); + minwords_ = caml_copy_double(minwords); + prowords_ = caml_copy_double(prowords); + majwords_ = caml_copy_double(majwords); + res = caml_alloc_3(0, minwords_, prowords_, majwords_); + CAMLreturn(res); } CAMLprim value caml_gc_get(value v) From 41b74e3b4c0c4371364bf12f6e900a7836566a73 Mon Sep 17 00:00:00 2001 From: Max Slater Date: Tue, 3 Sep 2024 16:09:18 +0200 Subject: [PATCH 09/76] Fix specialization of float32 bigarray ref/set (#3006) * fix * add comment --- ocaml/lambda/translprim.ml | 10 ++++------ ocaml/typing/typeopt.ml | 20 +++++++++++++++----- ocaml/typing/typeopt.mli | 9 +++++++-- 3 files changed, 26 insertions(+), 13 deletions(-) diff --git a/ocaml/lambda/translprim.ml b/ocaml/lambda/translprim.ml index e0baa6089f2..304c926260d 100644 --- a/ocaml/lambda/translprim.ml +++ b/ocaml/lambda/translprim.ml @@ -1034,16 +1034,14 @@ let specialize_primitive env loc ty ~has_constant_constructor prim = if st = array_set_type then None else Some (Primitive (Parraysets (array_set_type, index_kind), arity)) end - | Primitive (Pbigarrayref(unsafe, n, Pbigarray_unknown, - Pbigarray_unknown_layout), arity), p1 :: _ -> begin - let (k, l) = bigarray_type_kind_and_layout env p1 in + | Primitive (Pbigarrayref(unsafe, n, kind, layout), arity), p1 :: _ -> begin + let (k, l) = bigarray_specialize_kind_and_layout env ~kind ~layout p1 in match k, l with | Pbigarray_unknown, Pbigarray_unknown_layout -> None | _, _ -> Some (Primitive (Pbigarrayref(unsafe, n, k, l), arity)) end - | Primitive (Pbigarrayset(unsafe, n, Pbigarray_unknown, - Pbigarray_unknown_layout), arity), p1 :: _ -> begin - let (k, l) = bigarray_type_kind_and_layout env p1 in + | Primitive (Pbigarrayset(unsafe, n, kind, layout), arity), p1 :: _ -> begin + let (k, l) = bigarray_specialize_kind_and_layout env ~kind ~layout p1 in match k, l with | Pbigarray_unknown, Pbigarray_unknown_layout -> None | _, _ -> Some (Primitive (Pbigarrayset(unsafe, n, k, l), arity)) diff --git a/ocaml/typing/typeopt.ml b/ocaml/typing/typeopt.ml index 9afbee69103..1fabff62eb8 100644 --- a/ocaml/typing/typeopt.ml +++ b/ocaml/typing/typeopt.ml @@ -227,14 +227,24 @@ let layout_table = ["c_layout", Pbigarray_c_layout; "fortran_layout", Pbigarray_fortran_layout] -let bigarray_type_kind_and_layout env typ = +let bigarray_specialize_kind_and_layout env ~kind ~layout typ = match scrape env typ with | Tconstr(_p, [_caml_type; elt_type; layout_type], _abbrev) -> - (bigarray_decode_type env elt_type kind_table Pbigarray_unknown, - bigarray_decode_type env layout_type layout_table - Pbigarray_unknown_layout) + let kind = + match kind with + | Pbigarray_unknown -> + bigarray_decode_type env elt_type kind_table Pbigarray_unknown + | _ -> kind + in + let layout = + match layout with + | Pbigarray_unknown_layout -> + bigarray_decode_type env layout_type layout_table Pbigarray_unknown_layout + | _ -> layout + in + (kind, layout) | _ -> - (Pbigarray_unknown, Pbigarray_unknown_layout) + (kind, layout) let value_kind_of_value_jkind jkind = let const_jkind = Jkind.default_to_value_and_get jkind in diff --git a/ocaml/typing/typeopt.mli b/ocaml/typing/typeopt.mli index f1eb370e5e0..b741ac7f813 100644 --- a/ocaml/typing/typeopt.mli +++ b/ocaml/typing/typeopt.mli @@ -32,8 +32,13 @@ val array_kind : Typedtree.expression -> Jkind.Sort.t -> Lambda.array_kind val array_pattern_kind : Typedtree.pattern -> Jkind.Sort.t -> Lambda.array_kind -val bigarray_type_kind_and_layout : - Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout + +(* If [kind] or [layout] is unknown, attempt to specialize it by examining the + type parameters of the bigarray. If [kind] or [length] is not unknown, returns + it unmodified. *) +val bigarray_specialize_kind_and_layout : + Env.t -> kind:Lambda.bigarray_kind -> layout:Lambda.bigarray_layout -> + Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout (* CR layouts v7: [layout], [function_return_layout], [function2_return_layout], and [layout_of_sort] have had location arguments added just to support the From 1ceaac2478be967f05cfc701682f8c14629b2276 Mon Sep 17 00:00:00 2001 From: Milan Tom <48379919+milan-tom@users.noreply.github.com> Date: Tue, 3 Sep 2024 12:05:07 -0400 Subject: [PATCH 10/76] Make OCaml Platform the default OCaml formatter for vscode workspace (#2931) Make OCaml platform the default OCaml formatter for vscode --- .vscode/extensions.json | 5 +++++ .vscode/settings.json | 7 +++++-- 2 files changed, 10 insertions(+), 2 deletions(-) create mode 100644 .vscode/extensions.json diff --git a/.vscode/extensions.json b/.vscode/extensions.json new file mode 100644 index 00000000000..84ebcbe38eb --- /dev/null +++ b/.vscode/extensions.json @@ -0,0 +1,5 @@ +{ + "recommendations": [ + "ocamllabs.ocaml-platform" + ] +} diff --git a/.vscode/settings.json b/.vscode/settings.json index 67b99b076f4..6a528c0bc2e 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -8,5 +8,8 @@ "smmintrin.h": "c", "tmmintrin.h": "c", "pmmintrin.h": "c" - } -} \ No newline at end of file + }, + "[ocaml]": { + "editor.defaultFormatter": "ocamllabs.ocaml-platform", + }, +} From b99796d650bb95b78379d237213f759e8ce62964 Mon Sep 17 00:00:00 2001 From: Milan Tom <48379919+milan-tom@users.noreply.github.com> Date: Wed, 4 Sep 2024 14:26:12 +0100 Subject: [PATCH 11/76] Add language extensions counters (#2991) * Add counters for some language extensions (`Comprehensions`, `Include_functor`, `Immutable_arrays`, `Module_strengthening`, `Labeled_tuples`) * Add tests for language extension counters * Fix labeled tuple counting * Add support for counting type occurrences of [iarray] * Add pattern occurrence test for immutable arrays * Fix `ocaml/tools/Makefile` formatting * Fix `ocaml/tools/Makefile` formatting * Fix `Profile.record_call_with_counters` docs * Change `typing_input` type to `typing_output_for_counters` * fmt * Fix labeled tuples `ml_counters` conmments * Add tests for nested language extensions --- ocaml/compilerlibs/Makefile.compilerlibs | 1 + ocaml/driver/compile_common.ml | 16 +- ocaml/dune | 12 +- ocaml/otherlibs/dynlink/Makefile | 1 + ocaml/otherlibs/dynlink/dune | 4 + .../comprehensions/ml_counters.ml | 30 ++++ .../ml_counters.ocamlc.reference | 2 + .../comprehensions/mli_counters.mli | 11 ++ .../mli_counters.ocamlc.reference | 2 + .../ml_counters.ml | 9 ++ .../ml_counters.ocamlc.reference | 2 + .../immutable_arrays/ml_counters.ml | 28 ++++ .../ml_counters.ocamlc.reference | 2 + .../immutable_arrays/mli_counters.mli | 16 ++ .../mli_counters.ocamlc.reference | 2 + .../include_functor/ml_counters.ml | 84 +++++++++++ .../ml_counters.ocamlc.reference | 2 + .../include_functor/mli_counters.mli | 15 ++ .../mli_counters.ocamlc.reference | 2 + .../labeled_tuples/ml_counters.ml | 18 +++ .../ml_counters.ocamlc.reference | 2 + .../labeled_tuples/mli_counters.mli | 11 ++ .../mli_counters.ocamlc.reference | 2 + .../module_strengthening/ml_counters.ml | 15 ++ .../ml_counters.ocamlc.reference | 2 + .../module_strengthening/mli_counters.mli | 15 ++ .../mli_counters.ocamlc.reference | 2 + .../language_extensions/nested/ml_counters.ml | 7 + .../nested/ml_counters.ocamlc.reference | 2 + .../nested/mli_counters.mli | 7 + .../nested/mli_counters.ocamlc.reference | 2 + .../counters/language_extensions/test.ml | 137 ++++++++++++++++++ ocaml/tools/Makefile | 15 +- ocaml/utils/.ocamlformat-enable | 2 + ocaml/utils/profile.ml | 9 ++ ocaml/utils/profile.mli | 7 + ocaml/utils/profile_counters_functions.ml | 115 +++++++++++++++ ocaml/utils/profile_counters_functions.mli | 5 + 38 files changed, 600 insertions(+), 16 deletions(-) create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/ml_counters.ml create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/ml_counters.ocamlc.reference create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/mli_counters.mli create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/mli_counters.ocamlc.reference create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/immutable_array_comprehensions/ml_counters.ml create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/immutable_array_comprehensions/ml_counters.ocamlc.reference create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/ml_counters.ml create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/ml_counters.ocamlc.reference create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/mli_counters.mli create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/mli_counters.ocamlc.reference create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/ml_counters.ml create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/ml_counters.ocamlc.reference create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/mli_counters.mli create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/mli_counters.ocamlc.reference create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/ml_counters.ml create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/ml_counters.ocamlc.reference create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/mli_counters.mli create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/mli_counters.ocamlc.reference create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/ml_counters.ml create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/ml_counters.ocamlc.reference create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/mli_counters.mli create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/mli_counters.ocamlc.reference create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/nested/ml_counters.ml create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/nested/ml_counters.ocamlc.reference create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/nested/mli_counters.mli create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/nested/mli_counters.ocamlc.reference create mode 100644 ocaml/testsuite/tests/profile/counters/language_extensions/test.ml create mode 100644 ocaml/utils/profile_counters_functions.ml create mode 100644 ocaml/utils/profile_counters_functions.mli diff --git a/ocaml/compilerlibs/Makefile.compilerlibs b/ocaml/compilerlibs/Makefile.compilerlibs index f1c725881c9..b018d71ed39 100644 --- a/ocaml/compilerlibs/Makefile.compilerlibs +++ b/ocaml/compilerlibs/Makefile.compilerlibs @@ -40,6 +40,7 @@ UTILS = \ utils/language_extension_kernel.cmo \ utils/language_extension.cmo \ utils/profile.cmo \ + utils/profile_counters_functions.cmo \ utils/terminfo.cmo \ utils/ccomp.cmo \ utils/warnings.cmo \ diff --git a/ocaml/driver/compile_common.ml b/ocaml/driver/compile_common.ml index 8b115ceb4f6..6449454c5bb 100644 --- a/ocaml/driver/compile_common.ml +++ b/ocaml/driver/compile_common.ml @@ -60,7 +60,13 @@ let parse_intf i = |> print_if i.ppf_dump Clflags.dump_source Pprintast.signature let typecheck_intf info ast = - Profile.(record_call typing) @@ fun () -> + Profile.( + record_call_with_counters + ~counter_f:(fun signature -> + Profile_counters_functions.( + count_language_extensions (Typedtree_signature_output signature))) + typing) + @@ fun () -> let tsg = ast |> Typemod.type_interface @@ -123,7 +129,13 @@ let parse_impl i = let typecheck_impl i parsetree = parsetree - |> Profile.(record typing) + |> Profile.( + record_with_counters + ~counter_f:(fun (typed_tree : Typedtree.implementation) -> + Profile_counters_functions.( + count_language_extensions + (Typedtree_implementation_output typed_tree))) + typing) (Typemod.type_implementation ~sourcefile:i.source_file i.output_prefix i.module_name i.env) |> print_if i.ppf_dump Clflags.dump_typedtree diff --git a/ocaml/dune b/ocaml/dune index 7cc4ada7b67..5a884b10635 100644 --- a/ocaml/dune +++ b/ocaml/dune @@ -88,12 +88,11 @@ (modules ;; UTILS config build_path_prefix_map misc identifiable numbers arg_helper clflags - debug profile terminfo ccomp warnings consistbl strongly_connected_components - targetint load_path int_replace_polymorphic_compare domainstate binutils - local_store target_system compilation_unit import_info linkage_name symbol - lazy_backtrack diffing diffing_with_keys - language_extension_kernel language_extension - zero_alloc_utils zero_alloc_annotations + debug profile profile_counters_functions terminfo ccomp warnings consistbl + strongly_connected_components targetint load_path int_replace_polymorphic_compare + domainstate binutils local_store target_system compilation_unit import_info + linkage_name symbol lazy_backtrack diffing diffing_with_keys language_extension_kernel + language_extension zero_alloc_utils zero_alloc_annotations ;; PARSING location longident docstrings printast syntaxerr ast_helper @@ -273,6 +272,7 @@ (clflags.mli as compiler-libs/clflags.mli) (language_extension.mli as compiler-libs/language_extension.mli) (profile.mli as compiler-libs/profile.mli) + (profile_counters_functions.mli as compiler-libs/profile_counters_functions.mli) (terminfo.mli as compiler-libs/terminfo.mli) (ccomp.mli as compiler-libs/ccomp.mli) (warnings.mli as compiler-libs/warnings.mli) diff --git a/ocaml/otherlibs/dynlink/Makefile b/ocaml/otherlibs/dynlink/Makefile index ad5833d942b..73c1a971d45 100644 --- a/ocaml/otherlibs/dynlink/Makefile +++ b/ocaml/otherlibs/dynlink/Makefile @@ -91,6 +91,7 @@ COMPILERLIBS_SOURCES=\ utils/language_extension_kernel.ml \ utils/language_extension.ml \ utils/profile.ml \ + utils/profile_counters_functions.ml \ utils/consistbl.ml \ utils/terminfo.ml \ utils/warnings.ml \ diff --git a/ocaml/otherlibs/dynlink/dune b/ocaml/otherlibs/dynlink/dune index f97163b7723..f98555868bc 100644 --- a/ocaml/otherlibs/dynlink/dune +++ b/ocaml/otherlibs/dynlink/dune @@ -168,6 +168,7 @@ (copy_files ../../utils/language_extension_kernel.ml) (copy_files ../../utils/language_extension.ml) (copy_files ../../utils/profile.ml) +(copy_files ../../utils/profile_counters_functions.ml) (copy_files ../../utils/consistbl.ml) (copy_files ../../utils/terminfo.ml) (copy_files ../../utils/warnings.ml) @@ -241,6 +242,7 @@ (copy_files ../../utils/language_extension_kernel.mli) (copy_files ../../utils/language_extension.mli) (copy_files ../../utils/profile.mli) +(copy_files ../../utils/profile_counters_functions.mli) (copy_files ../../utils/consistbl.mli) (copy_files ../../utils/terminfo.mli) (copy_files ../../utils/warnings.mli) @@ -362,6 +364,7 @@ .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Numbers.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Clflags.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Profile.cmo + ; .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Profile_counters_functions.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Debug.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Language_extension_kernel.cmo .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Language_extension.cmo @@ -449,6 +452,7 @@ .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Numbers.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Clflags.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Profile.cmx + ; .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Profile_counters_functions.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Debug.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Language_extension_kernel.cmx .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Language_extension.cmx diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/ml_counters.ml b/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/ml_counters.ml new file mode 100644 index 00000000000..0456e2b7949 --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/ml_counters.ml @@ -0,0 +1,30 @@ +(* List comprehensions *) + +[x for x = 1 to 5];; + +[x * 2 for x = 1 to 5];; + +[x * 2 for x = 1 to 5 when x mod 2 <> 1];; + +[((x + y) * (x + y + 1)) / 2 + 1 for x = 1 to 5 for y = 1 to 5];; + +(* Array comprehensions *) + +[|x for x = 1 to 5|];; + +[|x * 2 for x = 1 to 5|];; + +[|x * 2 for x = 1 to 5 when x mod 2 <> 1|];; + +[|((x + y) * (x + y + 1)) / 2 + 1 for x = 1 to 5 for y = 1 to 5|];; + +(* Normal lists and arrays (should not be counted) *) + +[1; 2; 3; 4; 5];; +[|1; 2; 3; 4; 5|];; + +module type M = sig + val x : 'a list + + val y : 'a array +end diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/ml_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/ml_counters.ocamlc.reference new file mode 100644 index 00000000000..814d710a4f9 --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/ml_counters.ocamlc.reference @@ -0,0 +1,2 @@ + comprehensions/ml_counters.ml + [comprehensions = 8; immutable_arrays = 0; include_functor = 0; labeled_tuples = 0; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/mli_counters.mli b/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/mli_counters.mli new file mode 100644 index 00000000000..be67243f2ed --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/mli_counters.mli @@ -0,0 +1,11 @@ +(* Normal lists and arrays (should not be counted) *) + +val x : 'a list + +val y : 'a array + +module type M = sig + val x : 'a list + + val y : 'a array +end diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/mli_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/mli_counters.ocamlc.reference new file mode 100644 index 00000000000..64a4ff55404 --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/mli_counters.ocamlc.reference @@ -0,0 +1,2 @@ + comprehensions/mli_counters.mli + [comprehensions = 0; immutable_arrays = 0; include_functor = 0; labeled_tuples = 0; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_array_comprehensions/ml_counters.ml b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_array_comprehensions/ml_counters.ml new file mode 100644 index 00000000000..ff96be5d3e1 --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_array_comprehensions/ml_counters.ml @@ -0,0 +1,9 @@ +(* Immutable array comprehensions *) + +[:x for x = 1 to 5:];; + +[:x * 2 for x = 1 to 5:];; + +[:x * 2 for x = 1 to 5 when x mod 2 <> 1:];; + +[:((x + y) * (x + y + 1)) / 2 + 1 for x = 1 to 5 for y = 1 to 5:];; diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_array_comprehensions/ml_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_array_comprehensions/ml_counters.ocamlc.reference new file mode 100644 index 00000000000..9f9e1c65ae3 --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_array_comprehensions/ml_counters.ocamlc.reference @@ -0,0 +1,2 @@ + immutable_array_comprehensions/ml_counters.ml + [comprehensions = 4; immutable_arrays = 4; include_functor = 0; labeled_tuples = 0; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/ml_counters.ml b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/ml_counters.ml new file mode 100644 index 00000000000..67fcca2938b --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/ml_counters.ml @@ -0,0 +1,28 @@ +(* Immutable arrays *) + +(* 2 type, 1 expression *) +let a_iarray : int iarray = [: 1; 2; 3; 4; 5 :] + +(* 2 type, 1 expression *) +let b_iarray : float iarray = [: 1.; 2.; 3.; 4.; 5. :] + +(* 1 expression, 1 pattern *) +let and_iarray = + match [: true; false :] with + | [: iarray_val_1; iarray_val_2 :] -> iarray_val_1 && iarray_val_2 + | _ -> false + +(* CR-someday mitom: Add tests for [Iarray] module from stdlib *) + +(* Mutable arrays (should not be counted) *) + +let c_array : int array = [| 1; 2; 3; 4; 5 |] + +let d_array : float array = [| 1.; 2.; 3.; 4.; 5. |] + +let e_array : bool array = [| true; false; true |] + +let and_array = + match [| true; false |] with + | [| array_val_1; array_val_2 |] -> array_val_1 && array_val_2 + | _ -> false diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/ml_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/ml_counters.ocamlc.reference new file mode 100644 index 00000000000..7fb7d4a72cd --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/ml_counters.ocamlc.reference @@ -0,0 +1,2 @@ + immutable_arrays/ml_counters.ml + [comprehensions = 0; immutable_arrays = 8; include_functor = 0; labeled_tuples = 0; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/mli_counters.mli b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/mli_counters.mli new file mode 100644 index 00000000000..c282c806954 --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/mli_counters.mli @@ -0,0 +1,16 @@ +(* Immutable arrays *) + +(* 1 type *) +val a_iarray : int iarray + +(* 1 type *) +val b_iarray : float iarray + +(* 1 type *) +val c_iarray : 'a iarray + +(* Mutable arrays (should not be counted) *) + +val a_array : int array + +val b_array : float array diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/mli_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/mli_counters.ocamlc.reference new file mode 100644 index 00000000000..a9cec28b4ad --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/mli_counters.ocamlc.reference @@ -0,0 +1,2 @@ + immutable_arrays/mli_counters.mli + [comprehensions = 0; immutable_arrays = 3; include_functor = 0; labeled_tuples = 0; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/ml_counters.ml b/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/ml_counters.ml new file mode 100644 index 00000000000..d473ccdaa1c --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/ml_counters.ml @@ -0,0 +1,84 @@ +module type M = sig + type 'a t + + val mapi : (int -> 'a -> 'b) -> 'a t -> 'b t +end + +module type F_M = sig + include M + + val map : ('a -> 'b) -> 'a t -> 'b t +end + +module F_Applicative (M : M) = struct + let map f = M.mapi (fun _ -> f) +end + +module G_Applicative (M : M) = struct + let map_i_plus_one f = M.mapi (fun i -> f (i + 1)) +end + +module F_Genarative (M : M) () = struct + let map f = M.mapi (fun _ -> f) +end + +module G_Generative (M : M) () = struct + let map_i_plus_one f = M.mapi (fun i -> f (i + 1)) +end + + +(* Include applicative functors *) + +module Example_1 = struct + type 'a t = 'a list + let mapi = List.mapi + + include functor F_Applicative + include functor G_Applicative +end + +module Example_2 = struct + type 'a t = 'a list + let mapi = List.mapi + + include functor F_Applicative +end + +(* Include generative functors *) + +module Example_3 = struct + type 'a t = 'a list + let mapi = List.mapi + + include functor F_Genarative + include functor G_Generative +end + +module Example_4 = struct + type 'a t = 'a list + let mapi = List.mapi + + include functor F_Genarative +end + +(* Standard functor usage (should not be counted) *) + +module Example_5 = struct + module A = struct + type 'a t = 'a list + let mapi = List.mapi + end + + include F_Applicative (A) + include G_Applicative (A) +end + +module Example_6 = struct + module A = struct + type 'a t = 'a list + let mapi = List.mapi + end + + include F_Genarative (A) () + include G_Generative (A) () +end diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/ml_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/ml_counters.ocamlc.reference new file mode 100644 index 00000000000..e8f7df3c3eb --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/ml_counters.ocamlc.reference @@ -0,0 +1,2 @@ + include_functor/ml_counters.ml + [comprehensions = 0; immutable_arrays = 0; include_functor = 6; labeled_tuples = 0; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/mli_counters.mli b/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/mli_counters.mli new file mode 100644 index 00000000000..af4ce46a181 --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/mli_counters.mli @@ -0,0 +1,15 @@ +module type M = sig + type t = int +end + +module type F = functor (M : M) -> sig + type t_list = M.t list +end + +(* Include functor *) + +module type Example_1 = sig + type t = int + + include functor F +end diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/mli_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/mli_counters.ocamlc.reference new file mode 100644 index 00000000000..063679817dc --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/mli_counters.ocamlc.reference @@ -0,0 +1,2 @@ + include_functor/mli_counters.mli + [comprehensions = 0; immutable_arrays = 0; include_functor = 1; labeled_tuples = 0; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/ml_counters.ml b/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/ml_counters.ml new file mode 100644 index 00000000000..41820b2f5a5 --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/ml_counters.ml @@ -0,0 +1,18 @@ +(* Labeled tuples usage *) + +(* 1 expression *) +let labeled_1 = ~x:1, ~y:2, 3 + +(* 1 type, 1 expression *) +let (labeled_2 : x:int * int * y:int) = ~x:4, 5, ~y:6 + +(* 1 pattern *) +let ~x, ~y, _ = labeled_1 + +(* Unlabeled tuples usage (should not count) *) + +let (normal_1 : int * int * int) = 1, 2, 3 + +let a, b, c = 4, 5, 6 + +let _, b, _ = 7, 8, 9 diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/ml_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/ml_counters.ocamlc.reference new file mode 100644 index 00000000000..93aeccd2c3f --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/ml_counters.ocamlc.reference @@ -0,0 +1,2 @@ + labeled_tuples/ml_counters.ml + [comprehensions = 0; immutable_arrays = 0; include_functor = 0; labeled_tuples = 4; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/mli_counters.mli b/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/mli_counters.mli new file mode 100644 index 00000000000..f0f029d7272 --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/mli_counters.mli @@ -0,0 +1,11 @@ +(* Labeled tuples *) + +val labeled_1 : x:int * int * y:int + +val labeled_2 : z:float * bool + +(* Unlabeled tuples (should not count) *) + +val normal_1 : int * int * int + +val normal_2 : float * bool diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/mli_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/mli_counters.ocamlc.reference new file mode 100644 index 00000000000..b73d9670a7f --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/mli_counters.ocamlc.reference @@ -0,0 +1,2 @@ + labeled_tuples/mli_counters.mli + [comprehensions = 0; immutable_arrays = 0; include_functor = 0; labeled_tuples = 2; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/ml_counters.ml b/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/ml_counters.ml new file mode 100644 index 00000000000..f2f251c8408 --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/ml_counters.ml @@ -0,0 +1,15 @@ +(* Module strengthening syntax *) + +module type Example_2 = sig + module type T = sig type t end + module M : T + module N : T with M +end + +(* Standard syntax (should not be counted) *) + +module type Example_1 = sig + module type T = sig type t end + module M : T + module N : sig type t = M.t end +end diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/ml_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/ml_counters.ocamlc.reference new file mode 100644 index 00000000000..680c041e33c --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/ml_counters.ocamlc.reference @@ -0,0 +1,2 @@ + module_strengthening/ml_counters.ml + [comprehensions = 0; immutable_arrays = 0; include_functor = 0; labeled_tuples = 0; module_strengthening = 1] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/mli_counters.mli b/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/mli_counters.mli new file mode 100644 index 00000000000..f2f251c8408 --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/mli_counters.mli @@ -0,0 +1,15 @@ +(* Module strengthening syntax *) + +module type Example_2 = sig + module type T = sig type t end + module M : T + module N : T with M +end + +(* Standard syntax (should not be counted) *) + +module type Example_1 = sig + module type T = sig type t end + module M : T + module N : sig type t = M.t end +end diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/mli_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/mli_counters.ocamlc.reference new file mode 100644 index 00000000000..f6dae797ef4 --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/mli_counters.ocamlc.reference @@ -0,0 +1,2 @@ + module_strengthening/mli_counters.mli + [comprehensions = 0; immutable_arrays = 0; include_functor = 0; labeled_tuples = 0; module_strengthening = 1] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/nested/ml_counters.ml b/ocaml/testsuite/tests/profile/counters/language_extensions/nested/ml_counters.ml new file mode 100644 index 00000000000..b7a86deb264 --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/nested/ml_counters.ml @@ -0,0 +1,7 @@ +(* Nested language extensions *) + +(* 2 comprehensions *) +[[x + y for y = 1 to 5] for x = 1 to 5];; + +(* 1 comprehension, 1 labeled tuple *) +[(~y:5, ~z:2, x) for x = 1 to 5];; diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/nested/ml_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/nested/ml_counters.ocamlc.reference new file mode 100644 index 00000000000..610fc01f33b --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/nested/ml_counters.ocamlc.reference @@ -0,0 +1,2 @@ + nested/ml_counters.ml + [comprehensions = 3; immutable_arrays = 0; include_functor = 0; labeled_tuples = 1; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/nested/mli_counters.mli b/ocaml/testsuite/tests/profile/counters/language_extensions/nested/mli_counters.mli new file mode 100644 index 00000000000..68302c947cd --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/nested/mli_counters.mli @@ -0,0 +1,7 @@ +(* Nested language extensions *) + +(* 2 labeled tuples *) +val nested_labeled_tuple : z:(x:int * int * y:int) * int + +(* 1 labeled tuple, 1 immutable array *) +val nested_labeled_tuple_iarray : (x:int * int * y:int) iarray diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/nested/mli_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/nested/mli_counters.ocamlc.reference new file mode 100644 index 00000000000..5ce740eb0b1 --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/nested/mli_counters.ocamlc.reference @@ -0,0 +1,2 @@ + nested/mli_counters.mli + [comprehensions = 0; immutable_arrays = 1; include_functor = 0; labeled_tuples = 3; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/test.ml b/ocaml/testsuite/tests/profile/counters/language_extensions/test.ml new file mode 100644 index 00000000000..525d7f7cd0d --- /dev/null +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/test.ml @@ -0,0 +1,137 @@ +(* TEST + +subdirectories = "include_functor immutable_array_comprehensions comprehensions \ + immutable_arrays module_strengthening labeled_tuples nested"; +setup-ocamlc.byte-build-env; +ocamlc_byte_exit_status = "0"; +flags = "-dcounters -extension include_functor -extension comprehensions \ + -extension immutable_arrays -extension immutable_arrays \ + -extension module_strengthening -extension labeled_tuples"; + + + +(* Include functor *) +{ + module = "include_functor/ml_counters.ml"; + setup-ocamlc.byte-build-env; + ocamlc.byte; + compiler_reference = + "${test_source_directory}/include_functor/ml_counters.ocamlc.reference"; + check-ocamlc.byte-output; +} +{ + module = "include_functor/mli_counters.mli"; + setup-ocamlc.byte-build-env; + ocamlc.byte; + compiler_reference = + "${test_source_directory}/include_functor/mli_counters.ocamlc.reference"; + check-ocamlc.byte-output; +} + +(* Immutable array comprehensions *) + +{ + module = "immutable_array_comprehensions/ml_counters.ml"; + setup-ocamlc.byte-build-env; + ocamlc.byte; + compiler_reference = + "${test_source_directory}/immutable_array_comprehensions/ml_counters.ocamlc.reference"; + check-ocamlc.byte-output; +} + +(* Comprehensions *) + +{ + module = "comprehensions/ml_counters.ml"; + setup-ocamlc.byte-build-env; + ocamlc.byte; + compiler_reference = + "${test_source_directory}/comprehensions/ml_counters.ocamlc.reference"; + check-ocamlc.byte-output; +} +{ + module = "comprehensions/mli_counters.mli"; + setup-ocamlc.byte-build-env; + ocamlc.byte; + compiler_reference = + "${test_source_directory}/comprehensions/mli_counters.ocamlc.reference"; + check-ocamlc.byte-output; +} + +(* Immutable arrays *) + +{ + module = "immutable_arrays/ml_counters.ml"; + setup-ocamlc.byte-build-env; + ocamlc.byte; + compiler_reference = + "${test_source_directory}/immutable_arrays/ml_counters.ocamlc.reference"; + check-ocamlc.byte-output; +} +{ + module = "immutable_arrays/mli_counters.mli"; + setup-ocamlc.byte-build-env; + ocamlc.byte; + compiler_reference = + "${test_source_directory}/immutable_arrays/mli_counters.ocamlc.reference"; + check-ocamlc.byte-output; +} + +(* Labeled tuples *) + +{ + module = "labeled_tuples/ml_counters.ml"; + setup-ocamlc.byte-build-env; + ocamlc.byte; + compiler_reference = + "${test_source_directory}/labeled_tuples/ml_counters.ocamlc.reference"; + check-ocamlc.byte-output; +} +{ + module = "labeled_tuples/mli_counters.mli"; + setup-ocamlc.byte-build-env; + ocamlc.byte; + compiler_reference = + "${test_source_directory}/labeled_tuples/mli_counters.ocamlc.reference"; + check-ocamlc.byte-output; +} + +(* Module strengthening *) + +{ + module = "module_strengthening/ml_counters.ml"; + setup-ocamlc.byte-build-env; + ocamlc.byte; + compiler_reference = + "${test_source_directory}/module_strengthening/ml_counters.ocamlc.reference"; + check-ocamlc.byte-output; +} +{ + module = "module_strengthening/mli_counters.mli"; + setup-ocamlc.byte-build-env; + ocamlc.byte; + compiler_reference = + "${test_source_directory}/module_strengthening/mli_counters.ocamlc.reference"; + check-ocamlc.byte-output; +} + +(* Nested language extensions *) + +{ + module = "nested/ml_counters.ml"; + setup-ocamlc.byte-build-env; + ocamlc.byte; + compiler_reference = + "${test_source_directory}/nested/ml_counters.ocamlc.reference"; + check-ocamlc.byte-output; +} +{ + module = "nested/mli_counters.mli"; + setup-ocamlc.byte-build-env; + ocamlc.byte; + compiler_reference = + "${test_source_directory}/nested/mli_counters.ocamlc.reference"; + check-ocamlc.byte-output; +} + +*) diff --git a/ocaml/tools/Makefile b/ocaml/tools/Makefile index 71a8cdd5825..b8ebe82deb8 100644 --- a/ocaml/tools/Makefile +++ b/ocaml/tools/Makefile @@ -100,11 +100,10 @@ all: profiling.cmo opt.opt: profiling.cmx OCAMLCP = config.cmo build_path_prefix_map.cmo misc.cmo profile.cmo \ - warnings.cmo identifiable.cmo numbers.cmo arg_helper.cmo \ - language_extension_kernel.cmo language_extension.cmo \ - zero_alloc_annotations.cmo local_store.cmo \ - terminfo.cmo location.cmo clflags.cmo load_path.cmo ccomp.cmo compenv.cmo \ - main_args.cmo + profile_counters_functions.cmo \ warnings.cmo identifiable.cmo numbers.cmo \ + arg_helper.cmo language_extension_kernel.cmo language_extension.cmo \ + zero_alloc_annotations.cmo local_store.cmo \ terminfo.cmo location.cmo \ + clflags.cmo load_path.cmo ccomp.cmo compenv.cmo main_args.cmo ocamlcp$(EXE): $(OCAMLCP) ocamlcp.cmo ocamlcp.opt$(EXE): $(call byte2native, $(OCAMLCP) ocamlcp.cmo) @@ -137,9 +136,9 @@ ocamlmklib.opt$(EXE): $(call byte2native, $(OCAMLMKLIB)) # To make custom toplevels OCAMLMKTOP=config.cmo build_path_prefix_map.cmo misc.cmo \ - identifiable.cmo numbers.cmo arg_helper.cmo zero_alloc_annotations.cmo \ - clflags.cmo local_store.cmo load_path.cmo profile.cmo ccomp.cmo \ - ocamlmktop.cmo + identifiable.cmo numbers.cmo arg_helper.cmo zero_alloc_annotations.cmo \ + clflags.cmo local_store.cmo load_path.cmo profile.cmo \ + profile_counters_functions.cmo ccomp.cmo ocamlmktop.cmo ocamlmktop$(EXE): $(OCAMLMKTOP) ocamlmktop.opt$(EXE): $(call byte2native, $(OCAMLMKTOP)) diff --git a/ocaml/utils/.ocamlformat-enable b/ocaml/utils/.ocamlformat-enable index 2a6756eafe1..ff9cd15b3d3 100644 --- a/ocaml/utils/.ocamlformat-enable +++ b/ocaml/utils/.ocamlformat-enable @@ -6,3 +6,5 @@ language_extension.ml language_extension.mli zero_alloc_utils.ml zero_alloc_utils.mli +profile_counters_functions.ml +profile_counters_functions.mli diff --git a/ocaml/utils/profile.ml b/ocaml/utils/profile.ml index acb614030c3..16f10403c90 100644 --- a/ocaml/utils/profile.ml +++ b/ocaml/utils/profile.ml @@ -26,6 +26,12 @@ module Counters = struct let create () = String.Map.empty let get name t = String.Map.find_opt name t |> Option.value ~default:0 let set name count t = String.Map.add name count t + let incr name t = + String.Map.update name + (fun count_opt -> + let count = Option.value ~default:0 count_opt in + Some (succ count)) + t let is_empty = String.Map.is_empty let union = String.Map.union (fun _ count1 count2 -> Some (count1 + count2)) let to_string t = @@ -134,6 +140,9 @@ let record_call_internal ?(accumulate = false) ?counter_f name f = let record_call = record_call_internal ?counter_f:None +let record_call_with_counters ?accumulate ~counter_f = + record_call_internal ?accumulate ~counter_f + let record ?accumulate pass f x = record_call ?accumulate pass (fun () -> f x) let record_with_counters ?accumulate ~counter_f pass f x = diff --git a/ocaml/utils/profile.mli b/ocaml/utils/profile.mli index a83c35c9496..f6512b3b5b8 100644 --- a/ocaml/utils/profile.mli +++ b/ocaml/utils/profile.mli @@ -29,6 +29,7 @@ module Counters : sig val is_empty : t -> bool val get : string -> t -> int val set : string -> int -> t -> t + val incr : string -> t -> t val union : t -> t -> t val to_string : t -> string end @@ -39,6 +40,12 @@ val reset : unit -> unit val record_call : ?accumulate:bool -> string -> (unit -> 'a) -> 'a (** [record_call pass f] calls [f] and records its profile information. *) +val record_call_with_counters : + ?accumulate:bool -> counter_f:('a -> Counters.t) -> string -> (unit -> 'a) -> 'a +(** [record_call_with_counters counter_f pass f] calls [f] and records its profile + information (including counter information given by calling [counter_f] on the + result of calling [f]) *) + val record : ?accumulate:bool -> string -> ('a -> 'b) -> 'a -> 'b (** [record pass f arg] records the profile information of [f arg] *) diff --git a/ocaml/utils/profile_counters_functions.ml b/ocaml/utils/profile_counters_functions.ml new file mode 100644 index 00000000000..a8d2ab0567e --- /dev/null +++ b/ocaml/utils/profile_counters_functions.ml @@ -0,0 +1,115 @@ +type typing_output_for_counters = + | Typedtree_implementation_output of Typedtree.implementation + | Typedtree_signature_output of Typedtree.signature + +let count_language_extensions typing_input = + let counters = ref (Profile.Counters.create ()) in + let to_string : type a. a Language_extension_kernel.t -> string = + fun lang_ext -> + match lang_ext with + | Comprehensions | Include_functor | Immutable_arrays | Module_strengthening + | Labeled_tuples -> + Language_extension_kernel.to_string lang_ext + | Mode | Unique | Polymorphic_parameters | Layouts | SIMD | Small_numbers -> + let error_msg = + Format.sprintf "No counters supported for language extension : %s." + (Language_extension_kernel.to_string lang_ext) + in + failwith error_msg + in + let incr lang_ext = + counters := Profile.Counters.incr (to_string lang_ext) !counters + in + (* CR-someday mitom: Add support for counting stdlib [Iarray] usages *) + let supported_lang_exts = + Language_extension_kernel. + [ Comprehensions; + Include_functor; + Immutable_arrays; + Module_strengthening; + Labeled_tuples; + Immutable_arrays ] + in + List.iter + (fun lang_ext -> + counters := Profile.Counters.set (to_string lang_ext) 0 !counters) + supported_lang_exts; + let check_for_labeled_tuples label_opt_pair_list = + if List.exists + (fun (label_opt, _) -> Option.is_some label_opt) + label_opt_pair_list + then incr Labeled_tuples + in + let check_array_mutability mutability = + if not (Types.is_mutable mutability) then incr Immutable_arrays + in + let iterator = + Tast_iterator. + { default_iterator with + structure_item = + (fun sub ({ str_desc; _ } as si) -> + (match str_desc with + | Tstr_include include_declaration -> ( + match include_declaration.incl_kind with + | Tincl_functor _ | Tincl_gen_functor _ -> incr Include_functor + | Tincl_structure -> ()) + | _ -> ()); + default_iterator.structure_item sub si); + signature_item = + (fun sub ({ sig_desc; _ } as si) -> + (match sig_desc with + | Tsig_include (include_declaration, _) -> ( + match include_declaration.incl_kind with + | Tincl_functor _ | Tincl_gen_functor _ -> incr Include_functor + | Tincl_structure -> ()) + | _ -> ()); + default_iterator.signature_item sub si); + expr = + (fun sub ({ exp_desc; _ } as e) -> + (match exp_desc with + | Texp_list_comprehension _ -> incr Comprehensions + | Texp_array_comprehension (mutability, _, _) -> + incr Comprehensions; + check_array_mutability mutability + | Texp_array (mutability, _, _, _) -> + check_array_mutability mutability + | Texp_tuple (label_opt_pair_list, _) -> + check_for_labeled_tuples label_opt_pair_list + | _ -> ()); + default_iterator.expr sub e); + module_type = + (fun sub ({ mty_desc; _ } as mty) -> + (match mty_desc with + | Tmty_strengthen _ -> incr Module_strengthening + | _ -> ()); + default_iterator.module_type sub mty); + typ = + (fun sub ({ ctyp_desc; _ } as ctyp) -> + (match ctyp_desc with + | Ttyp_tuple label_opt_pair_list -> + check_for_labeled_tuples label_opt_pair_list + (* CR-someday mitom: type occurence of [iarray] double counted in + [let a_iarray : int iarray = [: 1; 2; 3; 4; 5 :]] *) + | Ttyp_constr (Pident ident, _, _) -> + if Ident.is_predef ident + && String.equal (Ident.name ident) "iarray" + then incr Immutable_arrays + | _ -> ()); + default_iterator.typ sub ctyp); + pat = + (fun (type k) sub + ({ pat_desc; _ } as gen_pat : k Typedtree.general_pattern) -> + (match pat_desc with + | Tpat_tuple label_opt_pair_list -> + check_for_labeled_tuples label_opt_pair_list + | Tpat_array (mutability, _, _) -> check_array_mutability mutability + | _ -> ()); + default_iterator.pat sub gen_pat) + } + in + (match typing_input with + | Typedtree_implementation_output tree -> + iterator.structure iterator tree.structure + | Typedtree_signature_output signature -> + iterator.signature iterator signature); + !counters diff --git a/ocaml/utils/profile_counters_functions.mli b/ocaml/utils/profile_counters_functions.mli new file mode 100644 index 00000000000..6d3b81fc7e2 --- /dev/null +++ b/ocaml/utils/profile_counters_functions.mli @@ -0,0 +1,5 @@ +type typing_output_for_counters = + | Typedtree_implementation_output of Typedtree.implementation + | Typedtree_signature_output of Typedtree.signature + +val count_language_extensions : typing_output_for_counters -> Profile.Counters.t From ed2ba77b5186bfbeaa81018fe04e3c6d3ea6a19f Mon Sep 17 00:00:00 2001 From: Milan Tom <48379919+milan-tom@users.noreply.github.com> Date: Wed, 4 Sep 2024 16:06:31 +0100 Subject: [PATCH 12/76] Make `OCaml Platform` default formatter for OCaml interface files in vscode (#3007) Make `OCaml Platform` the default formatter for OCaml interface files in vscode --- .vscode/settings.json | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.vscode/settings.json b/.vscode/settings.json index 6a528c0bc2e..e6fc35d6d2b 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -12,4 +12,7 @@ "[ocaml]": { "editor.defaultFormatter": "ocamllabs.ocaml-platform", }, + "[ocaml.interface]": { + "editor.defaultFormatter": "ocamllabs.ocaml-platform", + }, } From 7ad0b1c3d925faee8ffb49101063042e20337a0f Mon Sep 17 00:00:00 2001 From: Milan Tom <48379919+milan-tom@users.noreply.github.com> Date: Wed, 4 Sep 2024 16:47:15 +0100 Subject: [PATCH 13/76] Run compiler build for profiling in temporary directory (#2946) * Run compiler build for profiling in temporary directory * Use cp instead of git clone (and have temp dir as sibling of root dir) * Use `$0` * Ensure all expansions quoted * Make temp dir in neighbouring directory if and only if and only if `TMPDIR` is not set or empty --- scripts/profile-compiler-build.sh | 25 +++++++++++++++++++------ 1 file changed, 19 insertions(+), 6 deletions(-) diff --git a/scripts/profile-compiler-build.sh b/scripts/profile-compiler-build.sh index 4c91c18f8be..0f52542794c 100755 --- a/scripts/profile-compiler-build.sh +++ b/scripts/profile-compiler-build.sh @@ -1,11 +1,13 @@ #!/bin/sh -# To be run from the root of the Flambda backend repo - set -e -u -o pipefail -dump_dir="`pwd`/_profile" -summary_path="`pwd`/summary.csv" +# Works regardless of where script run from +scripts_dir=$( cd "$( dirname "$0" )" &> /dev/null && pwd ) + +root="$scripts_dir"/.. +dump_dir="$root"/_profile +summary_path="$root"/summary.csv if [ -d "$dump_dir" ] && [ "$(ls -A "$dump_dir")" ]; then echo "$dump_dir is not empty." @@ -33,12 +35,23 @@ export BUILD_OCAMLPARAM="$OCAMLPARAM" build_compiler() { git clean -Xdf autoconf - ./configure --enable-ocamltest --enable-warn-error --enable-dev --prefix=`pwd`/_install + ./configure --enable-ocamltest --enable-warn-error --enable-dev --prefix="$(pwd)"/_install make install } +if [ -v TMPDIR ] && [ ! -z "$TMPDIR" ]; then + temp_dir=$(mktemp -d) +else + temp_dir=$(mktemp -d -p "$root"/.. -t tmp.XXXXXXX) +fi +trap "rm -rf "$temp_dir"" EXIT +cp -r --reflink=auto "$root" "$temp_dir" + +cd "$temp_dir" build_compiler -python3 ./scripts/combine-profile-information.py "$dump_dir" -o "$summary_path" + +cd "$root" +python3 "$scripts_dir"/combine-profile-information.py "$dump_dir" -o "$summary_path" rm "$dump_dir/"*.csv rmdir "$dump_dir" From 9d28c35092ebfc69125d539b65c821a4062bbe4a Mon Sep 17 00:00:00 2001 From: Xavier Clerc Date: Wed, 4 Sep 2024 17:00:20 +0100 Subject: [PATCH 14/76] Split the `Selectgen` class (#3008) --- backend/selectgen.ml | 590 +++++++++++++++++++++++------------------- backend/selectgen.mli | 14 + 2 files changed, 334 insertions(+), 270 deletions(-) diff --git a/backend/selectgen.ml b/backend/selectgen.ml index c8761b65b59..d0f744528d0 100644 --- a/backend/selectgen.ml +++ b/backend/selectgen.ml @@ -25,10 +25,22 @@ module VP = Backend_var.With_provenance (* The default instruction selection class *) -type environment = unit Select_utils.environment - -class virtual selector_generic = +class virtual ['env, 'op, 'instr] common_selector = object (self : 'self) + method virtual is_store : 'op -> bool + + method virtual lift_op : 'op -> 'instr + + method virtual make_stack_offset : int -> 'instr + + method virtual make_name_for_debugger + : ident:V.t -> + which_parameter:int option -> + provenance:V.Provenance.t option -> + is_assignment:bool -> + regs:Reg.t array -> + 'instr + (* A syntactic criterion used in addition to judgements about (co)effects as to whether the evaluation of a given expression may be deferred by [emit_parts]. This criterion is a property of the instruction selection @@ -148,6 +160,311 @@ class virtual selector_generic = Cmm.expression -> Arch.addressing_mode * Cmm.expression + method virtual select_store + : bool -> Arch.addressing_mode -> Cmm.expression -> 'op * Cmm.expression + + (* Instruction selection for conditionals *) + + method select_condition (arg : Cmm.expression) : Mach.test * Cmm.expression + = + match arg with + | Cop (Ccmpi cmp, [arg1; Cconst_int (n, _)], _) + when self#is_immediate_test (Isigned cmp) n -> + Iinttest_imm (Isigned cmp, n), arg1 + | Cop (Ccmpi cmp, [Cconst_int (n, _); arg2], _) + when self#is_immediate_test (Isigned (swap_integer_comparison cmp)) n -> + Iinttest_imm (Isigned (swap_integer_comparison cmp), n), arg2 + | Cop (Ccmpi cmp, args, _) -> Iinttest (Isigned cmp), Ctuple args + | Cop (Ccmpa cmp, [arg1; Cconst_int (n, _)], _) + when self#is_immediate_test (Iunsigned cmp) n -> + Iinttest_imm (Iunsigned cmp, n), arg1 + | Cop (Ccmpa cmp, [Cconst_int (n, _); arg2], _) + when self#is_immediate_test (Iunsigned (swap_integer_comparison cmp)) n + -> + Iinttest_imm (Iunsigned (swap_integer_comparison cmp), n), arg2 + | Cop (Ccmpa cmp, args, _) -> Iinttest (Iunsigned cmp), Ctuple args + | Cop (Ccmpf (width, cmp), args, _) -> + Ifloattest (width, cmp), Ctuple args + | Cop (Cand, [arg1; Cconst_int (1, _)], _) -> Ioddtest, arg1 + | _ -> Itruetest, arg + + (* Return an array of fresh registers of the given type. Normally + implemented as Reg.createv, but some ports (e.g. Arm) can override this + definition to store float values in pairs of integer registers. *) + + method regs_for tys = Reg.createv tys + + method virtual insert_debug + : 'env Select_utils.environment -> + 'instr -> + Debuginfo.t -> + Reg.t array -> + Reg.t array -> + unit + + method virtual insert + : 'env Select_utils.environment -> + 'instr -> + Reg.t array -> + Reg.t array -> + unit + + method virtual insert_move + : 'env Select_utils.environment -> Reg.t -> Reg.t -> unit + + method insert_moves env src dst = + for i = 0 to min (Array.length src) (Array.length dst) - 1 do + self#insert_move env src.(i) dst.(i) + done + + (* Insert moves and stack offsets for function arguments and results *) + + method insert_move_args env arg loc stacksize = + if stacksize <> 0 + then self#insert env (self#make_stack_offset stacksize) [||] [||]; + self#insert_moves env arg loc + + method insert_move_results env loc res stacksize = + self#insert_moves env loc res; + if stacksize <> 0 + then self#insert env (self#make_stack_offset (-stacksize)) [||] [||] + + (* Add an Iop opcode. Can be overridden by processor description to insert + moves before and after the operation, i.e. for two-address instructions, + or instructions using dedicated registers. *) + + method insert_op_debug env op dbg rs rd = + self#insert_debug env (self#lift_op op) dbg rs rd; + rd + + method insert_op env op rs rd = + self#insert_op_debug env op Debuginfo.none rs rd + + method virtual emit_expr + : 'env Select_utils.environment -> + Cmm.expression -> + bound_name:VP.t option -> + Reg.t array option + + method private bind_let (env : 'env Select_utils.environment) v r1 = + let env = + if Select_utils.all_regs_anonymous r1 + then ( + Select_utils.name_regs v r1; + Select_utils.env_add v r1 env) + else + let rv = Reg.createv_like r1 in + Select_utils.name_regs v rv; + self#insert_moves env r1 rv; + Select_utils.env_add v rv env + in + let provenance = VP.provenance v in + (if Option.is_some provenance + then + let naming_op = + self#make_name_for_debugger ~ident:(VP.var v) ~which_parameter:None + ~provenance ~is_assignment:false ~regs:r1 + in + self#insert_debug env naming_op Debuginfo.none [||] [||]); + env + + method private bind_let_mut (env : 'env Select_utils.environment) v k r1 = + let rv = self#regs_for k in + Select_utils.name_regs v rv; + self#insert_moves env r1 rv; + let provenance = VP.provenance v in + (if Option.is_some provenance + then + let naming_op = + self#make_name_for_debugger ~ident:(VP.var v) ~which_parameter:None + ~provenance:(VP.provenance v) ~is_assignment:false ~regs:r1 + in + self#insert_debug env naming_op Debuginfo.none [||] [||]); + Select_utils.env_add ~mut:Mutable v rv env + + (* The following two functions, [emit_parts] and [emit_parts_list], force + right-to-left evaluation order as required by the Flambda [Un_anf] pass + (and to be consistent with the bytecode compiler). *) + + method private emit_parts (env : 'env Select_utils.environment) + ~effects_after exp = + let module EC = Select_utils.Effect_and_coeffect in + let may_defer_evaluation = + let ec = self#effects_of exp in + match EC.effect ec with + | Select_utils.Effect.Arbitrary | Select_utils.Effect.Raise -> + (* Preserve the ordering of effectful expressions by evaluating them + early (in the correct order) and assigning their results to + temporaries. We can avoid this in just one case: if we know that + every [exp'] in the original expression list (cf. + [emit_parts_list]) to be evaluated after [exp] cannot possibly + affect the result of [exp] or depend on the result of [exp], then + [exp] may be deferred. (Checking purity here is not enough: we need + to check copurity too to avoid e.g. moving mutable reads earlier + than the raising of an exception.) *) + EC.pure_and_copure effects_after + | Select_utils.Effect.None -> ( + match EC.coeffect ec with + | Select_utils.Coeffect.None -> + (* Pure expressions may be moved. *) + true + | Select_utils.Coeffect.Read_mutable -> ( + (* Read-mutable expressions may only be deferred if evaluation of + every [exp'] (for [exp'] as in the comment above) has no effects + "worse" (in the sense of the ordering in [Effect.t]) than raising + an exception. *) + match EC.effect effects_after with + | Select_utils.Effect.None | Select_utils.Effect.Raise -> true + | Select_utils.Effect.Arbitrary -> false) + | Select_utils.Coeffect.Arbitrary -> ( + (* Arbitrary expressions may only be deferred if evaluation of every + [exp'] (for [exp'] as in the comment above) has no effects. *) + match EC.effect effects_after with + | Select_utils.Effect.None -> true + | Select_utils.Effect.(Arbitrary | Raise) -> false)) + in + (* Even though some expressions may look like they can be deferred from + the (co)effect analysis, it may be forbidden to move them. *) + if may_defer_evaluation && self#is_simple_expr exp + then Some (exp, env) + else + match self#emit_expr env exp ~bound_name:None with + | None -> None + | Some r -> + if Array.length r = 0 + then Some (Ctuple [], env) + else + (* The normal case *) + let id = V.create_local "bind" in + if Select_utils.all_regs_anonymous r + then + (* r is an anonymous, unshared register; use it directly *) + Some (Cvar id, Select_utils.env_add (VP.create id) r env) + else + (* Introduce a fresh temp to hold the result *) + let tmp = Reg.createv_like r in + self#insert_moves env r tmp; + Some (Cvar id, Select_utils.env_add (VP.create id) tmp env) + + method private emit_parts_list (env : 'env Select_utils.environment) + exp_list = + let module EC = Select_utils.Effect_and_coeffect in + let exp_list_right_to_left, _effect = + (* Annotate each expression with the (co)effects that happen after it + when the original expression list is evaluated from right to left. + The resulting expression list has the rightmost expression first. *) + List.fold_left + (fun (exp_list, effects_after) exp -> + let exp_effect = self#effects_of exp in + (exp, effects_after) :: exp_list, EC.join exp_effect effects_after) + ([], EC.none) exp_list + in + List.fold_left + (fun results_and_env (exp, effects_after) -> + match results_and_env with + | None -> None + | Some (result, env) -> ( + match self#emit_parts env exp ~effects_after with + | None -> None + | Some (exp_result, env) -> Some (exp_result :: result, env))) + (Some ([], env)) + exp_list_right_to_left + + method private emit_tuple_not_flattened env exp_list = + let rec emit_list = function + | [] -> [] + | exp :: rem -> ( + (* Again, force right-to-left evaluation *) + let loc_rem = emit_list rem in + match self#emit_expr env exp ~bound_name:None with + | None -> assert false (* should have been caught in emit_parts *) + | Some loc_exp -> loc_exp :: loc_rem) + in + emit_list exp_list + + method private emit_tuple env exp_list = + Array.concat (self#emit_tuple_not_flattened env exp_list) + + method emit_extcall_args env ty_args args = + let args = self#emit_tuple_not_flattened env args in + let ty_args = + if ty_args = [] then List.map (fun _ -> XInt) args else ty_args + in + let locs, stack_ofs = Proc.loc_external_arguments ty_args in + let ty_args = Array.of_list ty_args in + if stack_ofs <> 0 + then self#insert env (Mach.Iop (Istackoffset stack_ofs)) [||] [||]; + List.iteri + (fun i arg -> self#insert_move_extcall_arg env ty_args.(i) arg locs.(i)) + args; + Array.concat (Array.to_list locs), stack_ofs + + method insert_move_extcall_arg env _ty_arg src dst = + (* The default implementation is one or two ordinary moves. (Two in the + case of an int64 argument on a 32-bit platform.) It can be overridden + to use special move instructions, for example a "32-bit move" + instruction for int32 arguments. *) + self#insert_moves env src dst + + method emit_stores env dbg data regs_addr = + let a = + ref (Arch.offset_addressing Arch.identity_addressing (-Arch.size_int)) + in + List.iter + (fun e -> + let op, arg = self#select_store false !a e in + match self#emit_expr env arg ~bound_name:None with + | None -> assert false + | Some regs -> ( + match self#is_store op with + | true -> + for i = 0 to Array.length regs - 1 do + let r = regs.(i) in + let kind = + match r.Reg.typ with + | Float -> Double + | Float32 -> Single { reg = Float32 } + | Vec128 -> + (* 128-bit memory operations are default unaligned. Aligned + (big)array operations are handled separately via cmm. *) + Onetwentyeight_unaligned + | Val | Addr | Int -> Word_val + in + self#insert_debug env + (Mach.Iop (Istore (kind, !a, false))) + dbg + (Array.append [| r |] regs_addr) + [||]; + a + := Arch.offset_addressing !a + (Select_utils.size_component r.Reg.typ) + done + | false -> + self#insert_debug env (Mach.Iop op) dbg + (Array.append regs regs_addr) + [||]; + a := Arch.offset_addressing !a (Select_utils.size_expr env e))) + data + end + +type environment = unit Select_utils.environment + +class virtual selector_generic = + object (self : 'self) + inherit [unit, Mach.operation, Mach.instruction_desc] common_selector + + method is_store op = match op with Istore (_, _, _) -> true | _ -> false + + method lift_op op = Iop op + + method make_stack_offset stack_ofs = Iop (Istackoffset stack_ofs) + + method make_name_for_debugger ~ident ~which_parameter ~provenance + ~is_assignment ~regs = + Mach.Iop + (Mach.Iname_for_debugger + { ident; which_parameter; provenance; is_assignment; regs }) + (* Default instruction selection for stores (of words) *) method select_store is_assign addr arg : Mach.operation * Cmm.expression = @@ -290,37 +607,6 @@ class virtual selector_generic = Iintop_imm (Icomp (Select_utils.swap_intcomp cmp), n), [arg] | _ -> Iintop (Icomp cmp), args - (* Instruction selection for conditionals *) - - method select_condition (arg : Cmm.expression) : Mach.test * Cmm.expression - = - match arg with - | Cop (Ccmpi cmp, [arg1; Cconst_int (n, _)], _) - when self#is_immediate_test (Isigned cmp) n -> - Iinttest_imm (Isigned cmp, n), arg1 - | Cop (Ccmpi cmp, [Cconst_int (n, _); arg2], _) - when self#is_immediate_test (Isigned (swap_integer_comparison cmp)) n -> - Iinttest_imm (Isigned (swap_integer_comparison cmp), n), arg2 - | Cop (Ccmpi cmp, args, _) -> Iinttest (Isigned cmp), Ctuple args - | Cop (Ccmpa cmp, [arg1; Cconst_int (n, _)], _) - when self#is_immediate_test (Iunsigned cmp) n -> - Iinttest_imm (Iunsigned cmp, n), arg1 - | Cop (Ccmpa cmp, [Cconst_int (n, _); arg2], _) - when self#is_immediate_test (Iunsigned (swap_integer_comparison cmp)) n - -> - Iinttest_imm (Iunsigned (swap_integer_comparison cmp), n), arg2 - | Cop (Ccmpa cmp, args, _) -> Iinttest (Iunsigned cmp), Ctuple args - | Cop (Ccmpf (width, cmp), args, _) -> - Ifloattest (width, cmp), Ctuple args - | Cop (Cand, [arg1; Cconst_int (1, _)], _) -> Ioddtest, arg1 - | _ -> Itruetest, arg - - (* Return an array of fresh registers of the given type. Normally - implemented as Reg.createv, but some ports (e.g. Arm) can override this - definition to store float values in pairs of integer registers. *) - - method regs_for tys = Reg.createv tys - (* Buffering of instruction sequences *) val mutable instr_seq = Mach.dummy_instr @@ -348,34 +634,6 @@ class virtual selector_generic = if src.Reg.stamp <> dst.Reg.stamp then self#insert env Mach.(Iop Imove) [| src |] [| dst |] - method insert_moves env src dst = - for i = 0 to min (Array.length src) (Array.length dst) - 1 do - self#insert_move env src.(i) dst.(i) - done - - (* Insert moves and stack offsets for function arguments and results *) - - method insert_move_args env arg loc stacksize = - if stacksize <> 0 - then self#insert env Mach.(Iop (Istackoffset stacksize)) [||] [||]; - self#insert_moves env arg loc - - method insert_move_results env loc res stacksize = - self#insert_moves env loc res; - if stacksize <> 0 - then self#insert env Mach.(Iop (Istackoffset (-stacksize))) [||] [||] - - (* Add an Iop opcode. Can be overridden by processor description to insert - moves before and after the operation, i.e. for two-address instructions, - or instructions using dedicated registers. *) - - method insert_op_debug env op dbg rs rd = - self#insert_debug env Mach.(Iop op) dbg rs rd; - rd - - method insert_op env op rs rd = - self#insert_op_debug env op Debuginfo.none rs rd - (* Emit an expression. [bound_name] is the name that will be bound to the result of evaluating @@ -864,214 +1122,6 @@ class virtual selector_generic = let r = s#emit_expr_aux env exp ~bound_name in r, s - method private bind_let (env : environment) v r1 = - let env = - if Select_utils.all_regs_anonymous r1 - then ( - Select_utils.name_regs v r1; - Select_utils.env_add v r1 env) - else - let rv = Reg.createv_like r1 in - Select_utils.name_regs v rv; - self#insert_moves env r1 rv; - Select_utils.env_add v rv env - in - let provenance = VP.provenance v in - (if Option.is_some provenance - then - let naming_op = - Mach.Iname_for_debugger - { ident = VP.var v; - which_parameter = None; - provenance; - is_assignment = false; - regs = r1 - } - in - self#insert_debug env (Mach.Iop naming_op) Debuginfo.none [||] [||]); - env - - method private bind_let_mut (env : environment) v k r1 = - let rv = self#regs_for k in - Select_utils.name_regs v rv; - self#insert_moves env r1 rv; - let provenance = VP.provenance v in - (if Option.is_some provenance - then - let naming_op = - Mach.Iname_for_debugger - { ident = VP.var v; - which_parameter = None; - provenance = VP.provenance v; - is_assignment = false; - regs = r1 - } - in - self#insert_debug env (Mach.Iop naming_op) Debuginfo.none [||] [||]); - Select_utils.env_add ~mut:Mutable v rv env - - (* The following two functions, [emit_parts] and [emit_parts_list], force - right-to-left evaluation order as required by the Flambda [Un_anf] pass - (and to be consistent with the bytecode compiler). *) - - method private emit_parts (env : environment) ~effects_after exp = - let module EC = Select_utils.Effect_and_coeffect in - let may_defer_evaluation = - let ec = self#effects_of exp in - match EC.effect ec with - | Select_utils.Effect.Arbitrary | Select_utils.Effect.Raise -> - (* Preserve the ordering of effectful expressions by evaluating them - early (in the correct order) and assigning their results to - temporaries. We can avoid this in just one case: if we know that - every [exp'] in the original expression list (cf. - [emit_parts_list]) to be evaluated after [exp] cannot possibly - affect the result of [exp] or depend on the result of [exp], then - [exp] may be deferred. (Checking purity here is not enough: we need - to check copurity too to avoid e.g. moving mutable reads earlier - than the raising of an exception.) *) - EC.pure_and_copure effects_after - | Select_utils.Effect.None -> ( - match EC.coeffect ec with - | Select_utils.Coeffect.None -> - (* Pure expressions may be moved. *) - true - | Select_utils.Coeffect.Read_mutable -> ( - (* Read-mutable expressions may only be deferred if evaluation of - every [exp'] (for [exp'] as in the comment above) has no effects - "worse" (in the sense of the ordering in [Effect.t]) than raising - an exception. *) - match EC.effect effects_after with - | Select_utils.Effect.None | Select_utils.Effect.Raise -> true - | Select_utils.Effect.Arbitrary -> false) - | Select_utils.Coeffect.Arbitrary -> ( - (* Arbitrary expressions may only be deferred if evaluation of every - [exp'] (for [exp'] as in the comment above) has no effects. *) - match EC.effect effects_after with - | Select_utils.Effect.None -> true - | Select_utils.Effect.(Arbitrary | Raise) -> false)) - in - (* Even though some expressions may look like they can be deferred from - the (co)effect analysis, it may be forbidden to move them. *) - if may_defer_evaluation && self#is_simple_expr exp - then Some (exp, env) - else - match self#emit_expr env exp ~bound_name:None with - | None -> None - | Some r -> - if Array.length r = 0 - then Some (Ctuple [], env) - else - (* The normal case *) - let id = V.create_local "bind" in - if Select_utils.all_regs_anonymous r - then - (* r is an anonymous, unshared register; use it directly *) - Some (Cvar id, Select_utils.env_add (VP.create id) r env) - else - (* Introduce a fresh temp to hold the result *) - let tmp = Reg.createv_like r in - self#insert_moves env r tmp; - Some (Cvar id, Select_utils.env_add (VP.create id) tmp env) - - method private emit_parts_list (env : environment) exp_list = - let module EC = Select_utils.Effect_and_coeffect in - let exp_list_right_to_left, _effect = - (* Annotate each expression with the (co)effects that happen after it - when the original expression list is evaluated from right to left. - The resulting expression list has the rightmost expression first. *) - List.fold_left - (fun (exp_list, effects_after) exp -> - let exp_effect = self#effects_of exp in - (exp, effects_after) :: exp_list, EC.join exp_effect effects_after) - ([], EC.none) exp_list - in - List.fold_left - (fun results_and_env (exp, effects_after) -> - match results_and_env with - | None -> None - | Some (result, env) -> ( - match self#emit_parts env exp ~effects_after with - | None -> None - | Some (exp_result, env) -> Some (exp_result :: result, env))) - (Some ([], env)) - exp_list_right_to_left - - method private emit_tuple_not_flattened env exp_list = - let rec emit_list = function - | [] -> [] - | exp :: rem -> ( - (* Again, force right-to-left evaluation *) - let loc_rem = emit_list rem in - match self#emit_expr env exp ~bound_name:None with - | None -> assert false (* should have been caught in emit_parts *) - | Some loc_exp -> loc_exp :: loc_rem) - in - emit_list exp_list - - method private emit_tuple env exp_list = - Array.concat (self#emit_tuple_not_flattened env exp_list) - - method emit_extcall_args env ty_args args = - let args = self#emit_tuple_not_flattened env args in - let ty_args = - if ty_args = [] then List.map (fun _ -> XInt) args else ty_args - in - let locs, stack_ofs = Proc.loc_external_arguments ty_args in - let ty_args = Array.of_list ty_args in - if stack_ofs <> 0 - then self#insert env (Mach.Iop (Istackoffset stack_ofs)) [||] [||]; - List.iteri - (fun i arg -> self#insert_move_extcall_arg env ty_args.(i) arg locs.(i)) - args; - Array.concat (Array.to_list locs), stack_ofs - - method insert_move_extcall_arg env _ty_arg src dst = - (* The default implementation is one or two ordinary moves. (Two in the - case of an int64 argument on a 32-bit platform.) It can be overridden - to use special move instructions, for example a "32-bit move" - instruction for int32 arguments. *) - self#insert_moves env src dst - - method emit_stores env dbg data regs_addr = - let a = - ref (Arch.offset_addressing Arch.identity_addressing (-Arch.size_int)) - in - List.iter - (fun e -> - let op, arg = self#select_store false !a e in - match self#emit_expr env arg ~bound_name:None with - | None -> assert false - | Some regs -> ( - match op with - | Istore (_, _, _) -> - for i = 0 to Array.length regs - 1 do - let r = regs.(i) in - let kind = - match r.Reg.typ with - | Float -> Double - | Float32 -> Single { reg = Float32 } - | Vec128 -> - (* 128-bit memory operations are default unaligned. Aligned - (big)array operations are handled separately via cmm. *) - Onetwentyeight_unaligned - | Val | Addr | Int -> Word_val - in - self#insert_debug env - (Mach.Iop (Istore (kind, !a, false))) - dbg - (Array.append [| r |] regs_addr) - [||]; - a - := Arch.offset_addressing !a - (Select_utils.size_component r.Reg.typ) - done - | _ -> - self#insert_debug env (Mach.Iop op) dbg - (Array.append regs regs_addr) - [||]; - a := Arch.offset_addressing !a (Select_utils.size_expr env e))) - data - (* Same, but in tail position *) method private insert_return (env : environment) r diff --git a/backend/selectgen.mli b/backend/selectgen.mli index f943d0a3c4d..d7f127a667b 100644 --- a/backend/selectgen.mli +++ b/backend/selectgen.mli @@ -22,6 +22,20 @@ type environment = unit Select_utils.environment class virtual selector_generic : object + method is_store : Mach.operation -> bool + + method lift_op : Mach.operation -> Mach.instruction_desc + + method make_stack_offset : int -> Mach.instruction_desc + + method make_name_for_debugger : + ident:Backend_var.t -> + which_parameter:int option -> + provenance:Backend_var.Provenance.t option -> + is_assignment:bool -> + regs:Reg.t array -> + Mach.instruction_desc + (* The following methods must or can be overridden by the processor description *) method is_immediate : Mach.integer_operation -> int -> bool From 41fd256602f03b027c3968258268db67c5c94696 Mon Sep 17 00:00:00 2001 From: Xavier Clerc Date: Wed, 4 Sep 2024 17:42:27 +0100 Subject: [PATCH 15/76] Selection: Move parent class to "utils" module (#3009) --- backend/select_utils.ml | 412 +++++++++++++++++++++++++++++++++++++ backend/select_utils.mli | 124 ++++++++++++ backend/selectgen.ml | 428 +-------------------------------------- backend/selectgen.mli | 3 + 4 files changed, 544 insertions(+), 423 deletions(-) diff --git a/backend/select_utils.ml b/backend/select_utils.ml index a2273350d30..8f29af49ea5 100644 --- a/backend/select_utils.ml +++ b/backend/select_utils.ml @@ -454,3 +454,415 @@ let select_effects (e : Cmm.effects) : Effect.t = let select_coeffects (e : Cmm.coeffects) : Coeffect.t = match e with No_coeffects -> None | Has_coeffects -> Arbitrary + +class virtual ['env, 'op, 'instr] common_selector = + object (self : 'self) + method virtual is_store : 'op -> bool + + method virtual lift_op : 'op -> 'instr + + method virtual make_store + : Cmm.memory_chunk -> Arch.addressing_mode -> bool -> 'instr + + method virtual make_stack_offset : int -> 'instr + + method virtual make_name_for_debugger + : ident:V.t -> + which_parameter:int option -> + provenance:V.Provenance.t option -> + is_assignment:bool -> + regs:Reg.t array -> + 'instr + + (* A syntactic criterion used in addition to judgements about (co)effects as + to whether the evaluation of a given expression may be deferred by + [emit_parts]. This criterion is a property of the instruction selection + algorithm in this file rather than a property of the Cmm language. *) + method is_simple_expr = + function + | Cconst_int _ -> true + | Cconst_natint _ -> true + | Cconst_float32 _ -> true + | Cconst_float _ -> true + | Cconst_symbol _ -> true + | Cconst_vec128 _ -> true + | Cvar _ -> true + | Ctuple el -> List.for_all self#is_simple_expr el + | Clet (_id, arg, body) | Clet_mut (_id, _, arg, body) -> + self#is_simple_expr arg && self#is_simple_expr body + | Cphantom_let (_var, _defining_expr, body) -> self#is_simple_expr body + | Csequence (e1, e2) -> self#is_simple_expr e1 && self#is_simple_expr e2 + | Cop (op, args, _) -> ( + match op with + (* Cextcall with neither effects nor coeffects is simple if its + arguments are *) + | Cextcall { effects = No_effects; coeffects = No_coeffects } -> + List.for_all self#is_simple_expr args + (* The following may have side effects *) + | Capply _ | Cextcall _ | Calloc _ | Cstore _ | Craise _ | Catomic _ + | Cprobe _ | Cprobe_is_enabled _ | Copaque -> + false + | Cprefetch _ | Cbeginregion | Cendregion -> + false + (* avoid reordering *) + (* The remaining operations are simple if their args are *) + | Cload _ | Caddi | Csubi | Cmuli | Cmulhi _ | Cdivi | Cmodi | Cand + | Cor | Cxor | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ + | Cnegf _ | Cclz _ | Cctz _ | Cpopcnt | Cbswap _ | Ccsel _ | Cabsf _ + | Caddf _ | Csubf _ | Cmulf _ | Cdivf _ | Cpackf32 | Creinterpret_cast _ + | Cstatic_cast _ | Ctuple_field _ | Ccmpf _ | Cdls_get -> + List.for_all self#is_simple_expr args) + | Cassign _ | Cifthenelse _ | Cswitch _ | Ccatch _ | Cexit _ | Ctrywith _ + -> + false + + (* Analyses the effects and coeffects of an expression. This is used across + a whole list of expressions with a view to determining which expressions + may have their evaluation deferred. The result of this function, modulo + target-specific judgements if the [effects_of] method is overridden, is a + property of the Cmm language rather than anything particular about the + instruction selection algorithm in this file. + + In the case of e.g. an OCaml function call, the arguments whose + evaluation cannot be deferred (cf. [emit_parts], below) are computed in + right-to-left order first with their results going into temporaries, then + the block is allocated, then the remaining arguments are evaluated before + being combined with the temporaries. *) + method effects_of exp = + let module EC = Effect_and_coeffect in + match exp with + | Cconst_int _ | Cconst_natint _ | Cconst_float32 _ | Cconst_float _ + | Cconst_symbol _ | Cconst_vec128 _ | Cvar _ -> + EC.none + | Ctuple el -> EC.join_list_map el self#effects_of + | Clet (_id, arg, body) | Clet_mut (_id, _, arg, body) -> + EC.join (self#effects_of arg) (self#effects_of body) + | Cphantom_let (_var, _defining_expr, body) -> self#effects_of body + | Csequence (e1, e2) -> EC.join (self#effects_of e1) (self#effects_of e2) + | Cifthenelse (cond, _ifso_dbg, ifso, _ifnot_dbg, ifnot, _dbg, _kind) -> + EC.join (self#effects_of cond) + (EC.join (self#effects_of ifso) (self#effects_of ifnot)) + | Cop (op, args, _) -> + let from_op = + match op with + | Cextcall { effects = e; coeffects = ce } -> + EC.create (select_effects e) (select_coeffects ce) + | Capply _ | Cprobe _ | Copaque -> EC.arbitrary + | Calloc Alloc_heap -> EC.none + | Calloc Alloc_local -> EC.coeffect_only Coeffect.Arbitrary + | Cstore _ -> EC.effect_only Effect.Arbitrary + | Cbeginregion | Cendregion -> EC.arbitrary + | Cprefetch _ -> EC.arbitrary + | Catomic _ -> EC.arbitrary + | Craise _ -> EC.effect_only Effect.Raise + | Cload { mutability = Asttypes.Immutable } -> EC.none + | Cload { mutability = Asttypes.Mutable } | Cdls_get -> + EC.coeffect_only Coeffect.Read_mutable + | Cprobe_is_enabled _ -> EC.coeffect_only Coeffect.Arbitrary + | Ctuple_field _ | Caddi | Csubi | Cmuli | Cmulhi _ | Cdivi | Cmodi + | Cand | Cor | Cxor | Cbswap _ | Ccsel _ | Cclz _ | Cctz _ | Cpopcnt + | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ | Cnegf _ + | Cabsf _ | Caddf _ | Csubf _ | Cmulf _ | Cdivf _ | Cpackf32 + | Creinterpret_cast _ | Cstatic_cast _ | Ccmpf _ -> + EC.none + in + EC.join from_op (EC.join_list_map args self#effects_of) + | Cassign _ | Cswitch _ | Ccatch _ | Cexit _ | Ctrywith _ -> EC.arbitrary + + (* Says whether an integer constant is a suitable immediate argument for the + given integer operation *) + + method is_immediate (op : Mach.integer_operation) n = + match op with + | Ilsl | Ilsr | Iasr -> n >= 0 && n < Arch.size_int * 8 + | _ -> false + + (* Says whether an integer constant is a suitable immediate argument for the + given integer test *) + + method virtual is_immediate_test : Mach.integer_comparison -> int -> bool + + (* Selection of addressing modes *) + + method virtual select_addressing + : Cmm.memory_chunk -> + Cmm.expression -> + Arch.addressing_mode * Cmm.expression + + method virtual select_store + : bool -> Arch.addressing_mode -> Cmm.expression -> 'op * Cmm.expression + + (* Instruction selection for conditionals *) + + method select_condition (arg : Cmm.expression) : Mach.test * Cmm.expression + = + match arg with + | Cop (Ccmpi cmp, [arg1; Cconst_int (n, _)], _) + when self#is_immediate_test (Isigned cmp) n -> + Iinttest_imm (Isigned cmp, n), arg1 + | Cop (Ccmpi cmp, [Cconst_int (n, _); arg2], _) + when self#is_immediate_test (Isigned (swap_integer_comparison cmp)) n -> + Iinttest_imm (Isigned (swap_integer_comparison cmp), n), arg2 + | Cop (Ccmpi cmp, args, _) -> Iinttest (Isigned cmp), Ctuple args + | Cop (Ccmpa cmp, [arg1; Cconst_int (n, _)], _) + when self#is_immediate_test (Iunsigned cmp) n -> + Iinttest_imm (Iunsigned cmp, n), arg1 + | Cop (Ccmpa cmp, [Cconst_int (n, _); arg2], _) + when self#is_immediate_test (Iunsigned (swap_integer_comparison cmp)) n + -> + Iinttest_imm (Iunsigned (swap_integer_comparison cmp), n), arg2 + | Cop (Ccmpa cmp, args, _) -> Iinttest (Iunsigned cmp), Ctuple args + | Cop (Ccmpf (width, cmp), args, _) -> + Ifloattest (width, cmp), Ctuple args + | Cop (Cand, [arg1; Cconst_int (1, _)], _) -> Ioddtest, arg1 + | _ -> Itruetest, arg + + (* Return an array of fresh registers of the given type. Normally + implemented as Reg.createv, but some ports (e.g. Arm) can override this + definition to store float values in pairs of integer registers. *) + + method regs_for tys = Reg.createv tys + + method virtual insert_debug + : 'env environment -> + 'instr -> + Debuginfo.t -> + Reg.t array -> + Reg.t array -> + unit + + method virtual insert + : 'env environment -> 'instr -> Reg.t array -> Reg.t array -> unit + + method virtual insert_move : 'env environment -> Reg.t -> Reg.t -> unit + + method insert_moves env src dst = + for i = 0 to min (Array.length src) (Array.length dst) - 1 do + self#insert_move env src.(i) dst.(i) + done + + (* Insert moves and stack offsets for function arguments and results *) + + method insert_move_args env arg loc stacksize = + if stacksize <> 0 + then self#insert env (self#make_stack_offset stacksize) [||] [||]; + self#insert_moves env arg loc + + method insert_move_results env loc res stacksize = + self#insert_moves env loc res; + if stacksize <> 0 + then self#insert env (self#make_stack_offset (-stacksize)) [||] [||] + + (* Add an Iop opcode. Can be overridden by processor description to insert + moves before and after the operation, i.e. for two-address instructions, + or instructions using dedicated registers. *) + + method insert_op_debug env op dbg rs rd = + self#insert_debug env (self#lift_op op) dbg rs rd; + rd + + method insert_op env op rs rd = + self#insert_op_debug env op Debuginfo.none rs rd + + method virtual emit_expr + : 'env environment -> + Cmm.expression -> + bound_name:VP.t option -> + Reg.t array option + + method private bind_let (env : 'env environment) v r1 = + let env = + if all_regs_anonymous r1 + then ( + name_regs v r1; + env_add v r1 env) + else + let rv = Reg.createv_like r1 in + name_regs v rv; + self#insert_moves env r1 rv; + env_add v rv env + in + let provenance = VP.provenance v in + (if Option.is_some provenance + then + let naming_op = + self#make_name_for_debugger ~ident:(VP.var v) ~which_parameter:None + ~provenance ~is_assignment:false ~regs:r1 + in + self#insert_debug env naming_op Debuginfo.none [||] [||]); + env + + method private bind_let_mut (env : 'env environment) v k r1 = + let rv = self#regs_for k in + name_regs v rv; + self#insert_moves env r1 rv; + let provenance = VP.provenance v in + (if Option.is_some provenance + then + let naming_op = + self#make_name_for_debugger ~ident:(VP.var v) ~which_parameter:None + ~provenance:(VP.provenance v) ~is_assignment:false ~regs:r1 + in + self#insert_debug env naming_op Debuginfo.none [||] [||]); + env_add ~mut:Mutable v rv env + + (* The following two functions, [emit_parts] and [emit_parts_list], force + right-to-left evaluation order as required by the Flambda [Un_anf] pass + (and to be consistent with the bytecode compiler). *) + + method private emit_parts (env : 'env environment) ~effects_after exp = + let module EC = Effect_and_coeffect in + let may_defer_evaluation = + let ec = self#effects_of exp in + match EC.effect ec with + | Effect.Arbitrary | Effect.Raise -> + (* Preserve the ordering of effectful expressions by evaluating them + early (in the correct order) and assigning their results to + temporaries. We can avoid this in just one case: if we know that + every [exp'] in the original expression list (cf. + [emit_parts_list]) to be evaluated after [exp] cannot possibly + affect the result of [exp] or depend on the result of [exp], then + [exp] may be deferred. (Checking purity here is not enough: we need + to check copurity too to avoid e.g. moving mutable reads earlier + than the raising of an exception.) *) + EC.pure_and_copure effects_after + | Effect.None -> ( + match EC.coeffect ec with + | Coeffect.None -> + (* Pure expressions may be moved. *) + true + | Coeffect.Read_mutable -> ( + (* Read-mutable expressions may only be deferred if evaluation of + every [exp'] (for [exp'] as in the comment above) has no effects + "worse" (in the sense of the ordering in [Effect.t]) than raising + an exception. *) + match EC.effect effects_after with + | Effect.None | Effect.Raise -> true + | Effect.Arbitrary -> false) + | Coeffect.Arbitrary -> ( + (* Arbitrary expressions may only be deferred if evaluation of every + [exp'] (for [exp'] as in the comment above) has no effects. *) + match EC.effect effects_after with + | Effect.None -> true + | Effect.(Arbitrary | Raise) -> false)) + in + (* Even though some expressions may look like they can be deferred from + the (co)effect analysis, it may be forbidden to move them. *) + if may_defer_evaluation && self#is_simple_expr exp + then Some (exp, env) + else + match self#emit_expr env exp ~bound_name:None with + | None -> None + | Some r -> + if Array.length r = 0 + then Some (Ctuple [], env) + else + (* The normal case *) + let id = V.create_local "bind" in + if all_regs_anonymous r + then + (* r is an anonymous, unshared register; use it directly *) + Some (Cvar id, env_add (VP.create id) r env) + else + (* Introduce a fresh temp to hold the result *) + let tmp = Reg.createv_like r in + self#insert_moves env r tmp; + Some (Cvar id, env_add (VP.create id) tmp env) + + method private emit_parts_list (env : 'env environment) exp_list = + let module EC = Effect_and_coeffect in + let exp_list_right_to_left, _effect = + (* Annotate each expression with the (co)effects that happen after it + when the original expression list is evaluated from right to left. + The resulting expression list has the rightmost expression first. *) + List.fold_left + (fun (exp_list, effects_after) exp -> + let exp_effect = self#effects_of exp in + (exp, effects_after) :: exp_list, EC.join exp_effect effects_after) + ([], EC.none) exp_list + in + List.fold_left + (fun results_and_env (exp, effects_after) -> + match results_and_env with + | None -> None + | Some (result, env) -> ( + match self#emit_parts env exp ~effects_after with + | None -> None + | Some (exp_result, env) -> Some (exp_result :: result, env))) + (Some ([], env)) + exp_list_right_to_left + + method private emit_tuple_not_flattened env exp_list = + let rec emit_list = function + | [] -> [] + | exp :: rem -> ( + (* Again, force right-to-left evaluation *) + let loc_rem = emit_list rem in + match self#emit_expr env exp ~bound_name:None with + | None -> assert false (* should have been caught in emit_parts *) + | Some loc_exp -> loc_exp :: loc_rem) + in + emit_list exp_list + + method private emit_tuple env exp_list = + Array.concat (self#emit_tuple_not_flattened env exp_list) + + method emit_extcall_args env ty_args args = + let args = self#emit_tuple_not_flattened env args in + let ty_args = + if ty_args = [] then List.map (fun _ -> XInt) args else ty_args + in + let locs, stack_ofs = Proc.loc_external_arguments ty_args in + let ty_args = Array.of_list ty_args in + if stack_ofs <> 0 + then self#insert env (self#make_stack_offset stack_ofs) [||] [||]; + List.iteri + (fun i arg -> self#insert_move_extcall_arg env ty_args.(i) arg locs.(i)) + args; + Array.concat (Array.to_list locs), stack_ofs + + method insert_move_extcall_arg env _ty_arg src dst = + (* The default implementation is one or two ordinary moves. (Two in the + case of an int64 argument on a 32-bit platform.) It can be overridden + to use special move instructions, for example a "32-bit move" + instruction for int32 arguments. *) + self#insert_moves env src dst + + method emit_stores env dbg data regs_addr = + let a = + ref (Arch.offset_addressing Arch.identity_addressing (-Arch.size_int)) + in + List.iter + (fun e -> + let op, arg = self#select_store false !a e in + match self#emit_expr env arg ~bound_name:None with + | None -> assert false + | Some regs -> ( + match self#is_store op with + | true -> + for i = 0 to Array.length regs - 1 do + let r = regs.(i) in + let kind = + match r.Reg.typ with + | Float -> Double + | Float32 -> Single { reg = Float32 } + | Vec128 -> + (* 128-bit memory operations are default unaligned. Aligned + (big)array operations are handled separately via cmm. *) + Onetwentyeight_unaligned + | Val | Addr | Int -> Word_val + in + self#insert_debug env + (self#make_store kind !a false) + dbg + (Array.append [| r |] regs_addr) + [||]; + a := Arch.offset_addressing !a (size_component r.Reg.typ) + done + | false -> + self#insert_debug env (self#lift_op op) dbg + (Array.append regs regs_addr) + [||]; + a := Arch.offset_addressing !a (size_expr env e))) + data + end diff --git a/backend/select_utils.mli b/backend/select_utils.mli index 85331646521..41af17113e3 100644 --- a/backend/select_utils.mli +++ b/backend/select_utils.mli @@ -176,3 +176,127 @@ end val select_effects : Cmm.effects -> Effect.t val select_coeffects : Cmm.coeffects -> Coeffect.t + +class virtual ['env, 'op, 'instr] common_selector : + object ('self) + method virtual is_store : 'op -> bool + + method virtual lift_op : 'op -> 'instr + + method virtual make_store : + Cmm.memory_chunk -> Arch.addressing_mode -> bool -> 'instr + + method virtual make_stack_offset : int -> 'instr + + method virtual make_name_for_debugger : + ident:Backend_var.t -> + which_parameter:int option -> + provenance:Backend_var.Provenance.t option -> + is_assignment:bool -> + regs:Reg.t array -> + 'instr + + method is_simple_expr : Cmm.expression -> bool + + method effects_of : Cmm.expression -> Effect_and_coeffect.t + + method is_immediate : Mach.integer_operation -> int -> bool + + method virtual is_immediate_test : Mach.integer_comparison -> int -> bool + + method virtual select_addressing : + Cmm.memory_chunk -> + Cmm.expression -> + Arch.addressing_mode * Cmm.expression + + method virtual select_store : + bool -> Arch.addressing_mode -> Cmm.expression -> 'op * Cmm.expression + + method select_condition : Cmm.expression -> Mach.test * Cmm.expression + + method regs_for : Cmm.machtype -> Reg.t array + + method virtual insert_debug : + 'env environment -> + 'instr -> + Debuginfo.t -> + Reg.t array -> + Reg.t array -> + unit + + method virtual insert : + 'env environment -> 'instr -> Reg.t array -> Reg.t array -> unit + + method virtual insert_move : 'env environment -> Reg.t -> Reg.t -> unit + + method insert_moves : 'env environment -> Reg.t array -> Reg.t array -> unit + + method insert_move_args : + 'env environment -> Reg.t array -> Reg.t array -> int -> unit + + method insert_move_results : + 'env environment -> Reg.t array -> Reg.t array -> int -> unit + + method insert_op_debug : + 'env environment -> + 'op -> + Debuginfo.t -> + Reg.t array -> + Reg.t array -> + Reg.t array + + method insert_op : + 'env environment -> 'op -> Reg.t array -> Reg.t array -> Reg.t array + + method virtual emit_expr : + 'env environment -> + Cmm.expression -> + bound_name:Backend_var.With_provenance.t option -> + Reg.t array option + + method private bind_let : + 'env environment -> + Backend_var.With_provenance.t -> + Reg.t array -> + 'env environment + + method private bind_let_mut : + 'env environment -> + Backend_var.With_provenance.t -> + Cmm.machtype -> + Reg.t array -> + 'env environment + + method private emit_parts : + 'env environment -> + effects_after:Effect_and_coeffect.t -> + Cmm.expression -> + (Cmm.expression * 'env environment) option + + method private emit_parts_list : + 'env environment -> + Cmm.expression list -> + (Cmm.expression list * 'env environment) option + + method private emit_tuple_not_flattened : + 'env environment -> Cmm.expression list -> Reg.t array list + + method private emit_tuple : + 'env environment -> Cmm.expression list -> Reg.t array + + method emit_extcall_args : + 'env environment -> + Cmm.exttype list -> + Cmm.expression list -> + Reg.t array * int + + method insert_move_extcall_arg : + 'env environment -> Cmm.exttype -> Reg.t array -> Reg.t array -> unit + + method emit_stores : + 'env environment -> + Debuginfo.t -> + Cmm.expression list -> + Reg.t array -> + unit + end diff --git a/backend/selectgen.ml b/backend/selectgen.ml index d0f744528d0..57475457554 100644 --- a/backend/selectgen.ml +++ b/backend/selectgen.ml @@ -25,438 +25,20 @@ module VP = Backend_var.With_provenance (* The default instruction selection class *) -class virtual ['env, 'op, 'instr] common_selector = - object (self : 'self) - method virtual is_store : 'op -> bool - - method virtual lift_op : 'op -> 'instr - - method virtual make_stack_offset : int -> 'instr - - method virtual make_name_for_debugger - : ident:V.t -> - which_parameter:int option -> - provenance:V.Provenance.t option -> - is_assignment:bool -> - regs:Reg.t array -> - 'instr - - (* A syntactic criterion used in addition to judgements about (co)effects as - to whether the evaluation of a given expression may be deferred by - [emit_parts]. This criterion is a property of the instruction selection - algorithm in this file rather than a property of the Cmm language. *) - method is_simple_expr = - function - | Cconst_int _ -> true - | Cconst_natint _ -> true - | Cconst_float32 _ -> true - | Cconst_float _ -> true - | Cconst_symbol _ -> true - | Cconst_vec128 _ -> true - | Cvar _ -> true - | Ctuple el -> List.for_all self#is_simple_expr el - | Clet (_id, arg, body) | Clet_mut (_id, _, arg, body) -> - self#is_simple_expr arg && self#is_simple_expr body - | Cphantom_let (_var, _defining_expr, body) -> self#is_simple_expr body - | Csequence (e1, e2) -> self#is_simple_expr e1 && self#is_simple_expr e2 - | Cop (op, args, _) -> ( - match op with - (* Cextcall with neither effects nor coeffects is simple if its - arguments are *) - | Cextcall { effects = No_effects; coeffects = No_coeffects } -> - List.for_all self#is_simple_expr args - (* The following may have side effects *) - | Capply _ | Cextcall _ | Calloc _ | Cstore _ | Craise _ | Catomic _ - | Cprobe _ | Cprobe_is_enabled _ | Copaque -> - false - | Cprefetch _ | Cbeginregion | Cendregion -> - false - (* avoid reordering *) - (* The remaining operations are simple if their args are *) - | Cload _ | Caddi | Csubi | Cmuli | Cmulhi _ | Cdivi | Cmodi | Cand - | Cor | Cxor | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ - | Cnegf _ | Cclz _ | Cctz _ | Cpopcnt | Cbswap _ | Ccsel _ | Cabsf _ - | Caddf _ | Csubf _ | Cmulf _ | Cdivf _ | Cpackf32 | Creinterpret_cast _ - | Cstatic_cast _ | Ctuple_field _ | Ccmpf _ | Cdls_get -> - List.for_all self#is_simple_expr args) - | Cassign _ | Cifthenelse _ | Cswitch _ | Ccatch _ | Cexit _ | Ctrywith _ - -> - false - - (* Analyses the effects and coeffects of an expression. This is used across - a whole list of expressions with a view to determining which expressions - may have their evaluation deferred. The result of this function, modulo - target-specific judgements if the [effects_of] method is overridden, is a - property of the Cmm language rather than anything particular about the - instruction selection algorithm in this file. - - In the case of e.g. an OCaml function call, the arguments whose - evaluation cannot be deferred (cf. [emit_parts], below) are computed in - right-to-left order first with their results going into temporaries, then - the block is allocated, then the remaining arguments are evaluated before - being combined with the temporaries. *) - method effects_of exp = - let module EC = Select_utils.Effect_and_coeffect in - match exp with - | Cconst_int _ | Cconst_natint _ | Cconst_float32 _ | Cconst_float _ - | Cconst_symbol _ | Cconst_vec128 _ | Cvar _ -> - EC.none - | Ctuple el -> EC.join_list_map el self#effects_of - | Clet (_id, arg, body) | Clet_mut (_id, _, arg, body) -> - EC.join (self#effects_of arg) (self#effects_of body) - | Cphantom_let (_var, _defining_expr, body) -> self#effects_of body - | Csequence (e1, e2) -> EC.join (self#effects_of e1) (self#effects_of e2) - | Cifthenelse (cond, _ifso_dbg, ifso, _ifnot_dbg, ifnot, _dbg, _kind) -> - EC.join (self#effects_of cond) - (EC.join (self#effects_of ifso) (self#effects_of ifnot)) - | Cop (op, args, _) -> - let from_op = - match op with - | Cextcall { effects = e; coeffects = ce } -> - EC.create - (Select_utils.select_effects e) - (Select_utils.select_coeffects ce) - | Capply _ | Cprobe _ | Copaque -> EC.arbitrary - | Calloc Alloc_heap -> EC.none - | Calloc Alloc_local -> - EC.coeffect_only Select_utils.Coeffect.Arbitrary - | Cstore _ -> EC.effect_only Select_utils.Effect.Arbitrary - | Cbeginregion | Cendregion -> EC.arbitrary - | Cprefetch _ -> EC.arbitrary - | Catomic _ -> EC.arbitrary - | Craise _ -> EC.effect_only Select_utils.Effect.Raise - | Cload { mutability = Asttypes.Immutable } -> EC.none - | Cload { mutability = Asttypes.Mutable } | Cdls_get -> - EC.coeffect_only Select_utils.Coeffect.Read_mutable - | Cprobe_is_enabled _ -> - EC.coeffect_only Select_utils.Coeffect.Arbitrary - | Ctuple_field _ | Caddi | Csubi | Cmuli | Cmulhi _ | Cdivi | Cmodi - | Cand | Cor | Cxor | Cbswap _ | Ccsel _ | Cclz _ | Cctz _ | Cpopcnt - | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ | Cnegf _ - | Cabsf _ | Caddf _ | Csubf _ | Cmulf _ | Cdivf _ | Cpackf32 - | Creinterpret_cast _ | Cstatic_cast _ | Ccmpf _ -> - EC.none - in - EC.join from_op (EC.join_list_map args self#effects_of) - | Cassign _ | Cswitch _ | Ccatch _ | Cexit _ | Ctrywith _ -> EC.arbitrary - - (* Says whether an integer constant is a suitable immediate argument for the - given integer operation *) - - method is_immediate (op : Mach.integer_operation) n = - match op with - | Ilsl | Ilsr | Iasr -> n >= 0 && n < Arch.size_int * 8 - | _ -> false - - (* Says whether an integer constant is a suitable immediate argument for the - given integer test *) - - method virtual is_immediate_test : Mach.integer_comparison -> int -> bool - - (* Selection of addressing modes *) - - method virtual select_addressing - : Cmm.memory_chunk -> - Cmm.expression -> - Arch.addressing_mode * Cmm.expression - - method virtual select_store - : bool -> Arch.addressing_mode -> Cmm.expression -> 'op * Cmm.expression - - (* Instruction selection for conditionals *) - - method select_condition (arg : Cmm.expression) : Mach.test * Cmm.expression - = - match arg with - | Cop (Ccmpi cmp, [arg1; Cconst_int (n, _)], _) - when self#is_immediate_test (Isigned cmp) n -> - Iinttest_imm (Isigned cmp, n), arg1 - | Cop (Ccmpi cmp, [Cconst_int (n, _); arg2], _) - when self#is_immediate_test (Isigned (swap_integer_comparison cmp)) n -> - Iinttest_imm (Isigned (swap_integer_comparison cmp), n), arg2 - | Cop (Ccmpi cmp, args, _) -> Iinttest (Isigned cmp), Ctuple args - | Cop (Ccmpa cmp, [arg1; Cconst_int (n, _)], _) - when self#is_immediate_test (Iunsigned cmp) n -> - Iinttest_imm (Iunsigned cmp, n), arg1 - | Cop (Ccmpa cmp, [Cconst_int (n, _); arg2], _) - when self#is_immediate_test (Iunsigned (swap_integer_comparison cmp)) n - -> - Iinttest_imm (Iunsigned (swap_integer_comparison cmp), n), arg2 - | Cop (Ccmpa cmp, args, _) -> Iinttest (Iunsigned cmp), Ctuple args - | Cop (Ccmpf (width, cmp), args, _) -> - Ifloattest (width, cmp), Ctuple args - | Cop (Cand, [arg1; Cconst_int (1, _)], _) -> Ioddtest, arg1 - | _ -> Itruetest, arg - - (* Return an array of fresh registers of the given type. Normally - implemented as Reg.createv, but some ports (e.g. Arm) can override this - definition to store float values in pairs of integer registers. *) - - method regs_for tys = Reg.createv tys - - method virtual insert_debug - : 'env Select_utils.environment -> - 'instr -> - Debuginfo.t -> - Reg.t array -> - Reg.t array -> - unit - - method virtual insert - : 'env Select_utils.environment -> - 'instr -> - Reg.t array -> - Reg.t array -> - unit - - method virtual insert_move - : 'env Select_utils.environment -> Reg.t -> Reg.t -> unit - - method insert_moves env src dst = - for i = 0 to min (Array.length src) (Array.length dst) - 1 do - self#insert_move env src.(i) dst.(i) - done - - (* Insert moves and stack offsets for function arguments and results *) - - method insert_move_args env arg loc stacksize = - if stacksize <> 0 - then self#insert env (self#make_stack_offset stacksize) [||] [||]; - self#insert_moves env arg loc - - method insert_move_results env loc res stacksize = - self#insert_moves env loc res; - if stacksize <> 0 - then self#insert env (self#make_stack_offset (-stacksize)) [||] [||] - - (* Add an Iop opcode. Can be overridden by processor description to insert - moves before and after the operation, i.e. for two-address instructions, - or instructions using dedicated registers. *) - - method insert_op_debug env op dbg rs rd = - self#insert_debug env (self#lift_op op) dbg rs rd; - rd - - method insert_op env op rs rd = - self#insert_op_debug env op Debuginfo.none rs rd - - method virtual emit_expr - : 'env Select_utils.environment -> - Cmm.expression -> - bound_name:VP.t option -> - Reg.t array option - - method private bind_let (env : 'env Select_utils.environment) v r1 = - let env = - if Select_utils.all_regs_anonymous r1 - then ( - Select_utils.name_regs v r1; - Select_utils.env_add v r1 env) - else - let rv = Reg.createv_like r1 in - Select_utils.name_regs v rv; - self#insert_moves env r1 rv; - Select_utils.env_add v rv env - in - let provenance = VP.provenance v in - (if Option.is_some provenance - then - let naming_op = - self#make_name_for_debugger ~ident:(VP.var v) ~which_parameter:None - ~provenance ~is_assignment:false ~regs:r1 - in - self#insert_debug env naming_op Debuginfo.none [||] [||]); - env - - method private bind_let_mut (env : 'env Select_utils.environment) v k r1 = - let rv = self#regs_for k in - Select_utils.name_regs v rv; - self#insert_moves env r1 rv; - let provenance = VP.provenance v in - (if Option.is_some provenance - then - let naming_op = - self#make_name_for_debugger ~ident:(VP.var v) ~which_parameter:None - ~provenance:(VP.provenance v) ~is_assignment:false ~regs:r1 - in - self#insert_debug env naming_op Debuginfo.none [||] [||]); - Select_utils.env_add ~mut:Mutable v rv env - - (* The following two functions, [emit_parts] and [emit_parts_list], force - right-to-left evaluation order as required by the Flambda [Un_anf] pass - (and to be consistent with the bytecode compiler). *) - - method private emit_parts (env : 'env Select_utils.environment) - ~effects_after exp = - let module EC = Select_utils.Effect_and_coeffect in - let may_defer_evaluation = - let ec = self#effects_of exp in - match EC.effect ec with - | Select_utils.Effect.Arbitrary | Select_utils.Effect.Raise -> - (* Preserve the ordering of effectful expressions by evaluating them - early (in the correct order) and assigning their results to - temporaries. We can avoid this in just one case: if we know that - every [exp'] in the original expression list (cf. - [emit_parts_list]) to be evaluated after [exp] cannot possibly - affect the result of [exp] or depend on the result of [exp], then - [exp] may be deferred. (Checking purity here is not enough: we need - to check copurity too to avoid e.g. moving mutable reads earlier - than the raising of an exception.) *) - EC.pure_and_copure effects_after - | Select_utils.Effect.None -> ( - match EC.coeffect ec with - | Select_utils.Coeffect.None -> - (* Pure expressions may be moved. *) - true - | Select_utils.Coeffect.Read_mutable -> ( - (* Read-mutable expressions may only be deferred if evaluation of - every [exp'] (for [exp'] as in the comment above) has no effects - "worse" (in the sense of the ordering in [Effect.t]) than raising - an exception. *) - match EC.effect effects_after with - | Select_utils.Effect.None | Select_utils.Effect.Raise -> true - | Select_utils.Effect.Arbitrary -> false) - | Select_utils.Coeffect.Arbitrary -> ( - (* Arbitrary expressions may only be deferred if evaluation of every - [exp'] (for [exp'] as in the comment above) has no effects. *) - match EC.effect effects_after with - | Select_utils.Effect.None -> true - | Select_utils.Effect.(Arbitrary | Raise) -> false)) - in - (* Even though some expressions may look like they can be deferred from - the (co)effect analysis, it may be forbidden to move them. *) - if may_defer_evaluation && self#is_simple_expr exp - then Some (exp, env) - else - match self#emit_expr env exp ~bound_name:None with - | None -> None - | Some r -> - if Array.length r = 0 - then Some (Ctuple [], env) - else - (* The normal case *) - let id = V.create_local "bind" in - if Select_utils.all_regs_anonymous r - then - (* r is an anonymous, unshared register; use it directly *) - Some (Cvar id, Select_utils.env_add (VP.create id) r env) - else - (* Introduce a fresh temp to hold the result *) - let tmp = Reg.createv_like r in - self#insert_moves env r tmp; - Some (Cvar id, Select_utils.env_add (VP.create id) tmp env) - - method private emit_parts_list (env : 'env Select_utils.environment) - exp_list = - let module EC = Select_utils.Effect_and_coeffect in - let exp_list_right_to_left, _effect = - (* Annotate each expression with the (co)effects that happen after it - when the original expression list is evaluated from right to left. - The resulting expression list has the rightmost expression first. *) - List.fold_left - (fun (exp_list, effects_after) exp -> - let exp_effect = self#effects_of exp in - (exp, effects_after) :: exp_list, EC.join exp_effect effects_after) - ([], EC.none) exp_list - in - List.fold_left - (fun results_and_env (exp, effects_after) -> - match results_and_env with - | None -> None - | Some (result, env) -> ( - match self#emit_parts env exp ~effects_after with - | None -> None - | Some (exp_result, env) -> Some (exp_result :: result, env))) - (Some ([], env)) - exp_list_right_to_left - - method private emit_tuple_not_flattened env exp_list = - let rec emit_list = function - | [] -> [] - | exp :: rem -> ( - (* Again, force right-to-left evaluation *) - let loc_rem = emit_list rem in - match self#emit_expr env exp ~bound_name:None with - | None -> assert false (* should have been caught in emit_parts *) - | Some loc_exp -> loc_exp :: loc_rem) - in - emit_list exp_list - - method private emit_tuple env exp_list = - Array.concat (self#emit_tuple_not_flattened env exp_list) - - method emit_extcall_args env ty_args args = - let args = self#emit_tuple_not_flattened env args in - let ty_args = - if ty_args = [] then List.map (fun _ -> XInt) args else ty_args - in - let locs, stack_ofs = Proc.loc_external_arguments ty_args in - let ty_args = Array.of_list ty_args in - if stack_ofs <> 0 - then self#insert env (Mach.Iop (Istackoffset stack_ofs)) [||] [||]; - List.iteri - (fun i arg -> self#insert_move_extcall_arg env ty_args.(i) arg locs.(i)) - args; - Array.concat (Array.to_list locs), stack_ofs - - method insert_move_extcall_arg env _ty_arg src dst = - (* The default implementation is one or two ordinary moves. (Two in the - case of an int64 argument on a 32-bit platform.) It can be overridden - to use special move instructions, for example a "32-bit move" - instruction for int32 arguments. *) - self#insert_moves env src dst - - method emit_stores env dbg data regs_addr = - let a = - ref (Arch.offset_addressing Arch.identity_addressing (-Arch.size_int)) - in - List.iter - (fun e -> - let op, arg = self#select_store false !a e in - match self#emit_expr env arg ~bound_name:None with - | None -> assert false - | Some regs -> ( - match self#is_store op with - | true -> - for i = 0 to Array.length regs - 1 do - let r = regs.(i) in - let kind = - match r.Reg.typ with - | Float -> Double - | Float32 -> Single { reg = Float32 } - | Vec128 -> - (* 128-bit memory operations are default unaligned. Aligned - (big)array operations are handled separately via cmm. *) - Onetwentyeight_unaligned - | Val | Addr | Int -> Word_val - in - self#insert_debug env - (Mach.Iop (Istore (kind, !a, false))) - dbg - (Array.append [| r |] regs_addr) - [||]; - a - := Arch.offset_addressing !a - (Select_utils.size_component r.Reg.typ) - done - | false -> - self#insert_debug env (Mach.Iop op) dbg - (Array.append regs regs_addr) - [||]; - a := Arch.offset_addressing !a (Select_utils.size_expr env e))) - data - end - type environment = unit Select_utils.environment class virtual selector_generic = object (self : 'self) - inherit [unit, Mach.operation, Mach.instruction_desc] common_selector + inherit + [unit, Mach.operation, Mach.instruction_desc] Select_utils.common_selector method is_store op = match op with Istore (_, _, _) -> true | _ -> false method lift_op op = Iop op + method make_store mem_chunk addr_mode is_assignment = + Mach.Iop (Mach.Istore (mem_chunk, addr_mode, is_assignment)) + method make_stack_offset stack_ofs = Iop (Istackoffset stack_ofs) method make_name_for_debugger ~ident ~which_parameter ~provenance diff --git a/backend/selectgen.mli b/backend/selectgen.mli index d7f127a667b..b5776ea2726 100644 --- a/backend/selectgen.mli +++ b/backend/selectgen.mli @@ -26,6 +26,9 @@ class virtual selector_generic : method lift_op : Mach.operation -> Mach.instruction_desc + method make_store : + Cmm.memory_chunk -> Arch.addressing_mode -> bool -> Mach.instruction_desc + method make_stack_offset : int -> Mach.instruction_desc method make_name_for_debugger : From 7ccc4f69fa271940a98597ad82ab21541117fc81 Mon Sep 17 00:00:00 2001 From: Chris Casinghino Date: Thu, 5 Sep 2024 14:56:09 +0100 Subject: [PATCH 16/76] Unboxed tuples (#2879) --- .../from_lambda/closure_conversion.ml | 2 +- ocaml/bytecomp/bytegen.ml | 7 +- ocaml/file_formats/cmt_format.ml | 5 +- ocaml/lambda/lambda.ml | 2 +- ocaml/lambda/lambda.mli | 2 +- ocaml/lambda/matching.ml | 90 +- ocaml/lambda/translcore.ml | 27 +- ocaml/lambda/translcore.mli | 1 + ocaml/lambda/translprim.ml | 44 +- ocaml/lambda/translprim.mli | 5 +- ocaml/ocamldoc/odoc_misc.ml | 1 + ocaml/ocamldoc/odoc_str.ml | 3 +- ocaml/ocamldoc/odoc_value.ml | 1 + ocaml/parsing/ast_helper.ml | 5 + ocaml/parsing/ast_helper.mli | 7 + ocaml/parsing/ast_iterator.ml | 24 +- ocaml/parsing/ast_mapper.ml | 27 +- ocaml/parsing/depend.ml | 18 +- ocaml/parsing/jane_syntax.ml | 6 + ocaml/parsing/jane_syntax.mli | 1 + ocaml/parsing/lexer.mll | 1 + ocaml/parsing/parser.mly | 41 +- ocaml/parsing/parsetree.mli | 24 + ocaml/parsing/pprintast.ml | 47 +- ocaml/parsing/printast.ml | 16 + .../pprintast_unconditional.ml | 5 + .../pprintast_unconditional.reference | 10 + .../tests/typing-layouts-err-msg/concrete.ml | 12 +- .../tests/typing-layouts-or-null/basics.ml | 4 +- .../tests/typing-layouts-products/basics.ml | 950 ++++++++++++++++++ .../typing-layouts-products/basics_alpha.ml | 96 ++ .../tests/typing-layouts-products/maturity.ml | 45 + .../parsing_nullary_term.compilers.reference | 4 + .../parsing_nullary_term.ml | 11 + .../parsing_nullary_type.compilers.reference | 4 + .../parsing_nullary_type.ml | 11 + .../parsing_unary_term.compilers.reference | 4 + .../parsing_unary_term.ml | 11 + .../parsing_unary_type.compilers.reference | 4 + .../parsing_unary_type.ml | 11 + .../typing-layouts-products/unboxed_tuples.ml | 458 +++++++++ .../unboxed_tuples.reference | 76 ++ ...nboxed_tuples_disabled.compilers.reference | 4 + .../unboxed_tuples_stable.compilers.reference | 4 + .../testsuite/tests/typing-layouts/annots.ml | 2 +- .../testsuite/tests/typing-layouts/basics.ml | 16 +- .../tests/typing-layouts/basics_alpha.ml | 14 +- .../tests/typing-layouts/layout_poly.ml | 2 +- .../tests/typing-layouts/printing.ml | 4 +- .../tests/typing-modes/tuple_modes.ml | 116 ++- .../tests/typing-unique/unique_analysis.ml | 32 +- ocaml/toplevel/genprintval.ml | 10 +- ocaml/typing/btype.ml | 3 + ocaml/typing/ctype.ml | 263 +++-- ocaml/typing/jkind.ml | 479 ++++++--- ocaml/typing/jkind.mli | 18 +- ocaml/typing/jkind_axis.ml | 15 + ocaml/typing/jkind_axis.mli | 2 + ocaml/typing/jkind_intf.ml | 15 +- ocaml/typing/jkind_types.ml | 466 ++++++--- ocaml/typing/jkind_types.mli | 30 +- ocaml/typing/oprint.ml | 51 +- ocaml/typing/outcometree.mli | 5 +- ocaml/typing/parmatch.ml | 52 +- ocaml/typing/patterns.ml | 14 + ocaml/typing/patterns.mli | 2 + ocaml/typing/predef.ml | 6 +- ocaml/typing/primitive.ml | 9 +- ocaml/typing/primitive.mli | 2 +- ocaml/typing/printpat.ml | 9 + ocaml/typing/printtyp.ml | 40 +- ocaml/typing/printtyped.ml | 22 + ocaml/typing/subst.ml | 9 +- ocaml/typing/tast_iterator.ml | 3 + ocaml/typing/tast_mapper.ml | 9 + ocaml/typing/typecore.ml | 178 +++- ocaml/typing/typedecl.ml | 90 +- ocaml/typing/typedecl.mli | 3 +- ocaml/typing/typedecl_separability.ml | 3 + ocaml/typing/typedecl_variance.ml | 2 + ocaml/typing/typedtree.ml | 16 +- ocaml/typing/typedtree.mli | 28 +- ocaml/typing/typemod.ml | 10 +- ocaml/typing/typeopt.ml | 114 ++- ocaml/typing/typeopt.mli | 4 +- ocaml/typing/types.ml | 1 + ocaml/typing/types.mli | 10 + ocaml/typing/typetexp.ml | 17 +- ocaml/typing/uniqueness_analysis.ml | 12 + ocaml/typing/untypeast.ml | 10 + ocaml/typing/value_rec_check.ml | 6 + ocaml/utils/misc.ml | 31 + ocaml/utils/misc.mli | 24 + printer/printast_with_mappings.ml | 16 + 94 files changed, 3800 insertions(+), 626 deletions(-) create mode 100644 ocaml/testsuite/tests/typing-layouts-products/basics.ml create mode 100644 ocaml/testsuite/tests/typing-layouts-products/basics_alpha.ml create mode 100644 ocaml/testsuite/tests/typing-layouts-products/maturity.ml create mode 100644 ocaml/testsuite/tests/typing-layouts-products/parsing_nullary_term.compilers.reference create mode 100644 ocaml/testsuite/tests/typing-layouts-products/parsing_nullary_term.ml create mode 100644 ocaml/testsuite/tests/typing-layouts-products/parsing_nullary_type.compilers.reference create mode 100644 ocaml/testsuite/tests/typing-layouts-products/parsing_nullary_type.ml create mode 100644 ocaml/testsuite/tests/typing-layouts-products/parsing_unary_term.compilers.reference create mode 100644 ocaml/testsuite/tests/typing-layouts-products/parsing_unary_term.ml create mode 100644 ocaml/testsuite/tests/typing-layouts-products/parsing_unary_type.compilers.reference create mode 100644 ocaml/testsuite/tests/typing-layouts-products/parsing_unary_type.ml create mode 100644 ocaml/testsuite/tests/typing-layouts-products/unboxed_tuples.ml create mode 100644 ocaml/testsuite/tests/typing-layouts-products/unboxed_tuples.reference create mode 100644 ocaml/testsuite/tests/typing-layouts-products/unboxed_tuples_disabled.compilers.reference create mode 100644 ocaml/testsuite/tests/typing-layouts-products/unboxed_tuples_stable.compilers.reference diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index 1286ca8f943..f73e867cc6e 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -604,7 +604,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds K.With_subkind.( kind (from_lambda_values_and_unboxed_numbers_only - (Typeopt.layout_of_const_sort sort))) + (Typeopt.layout_of_base_sort sort))) | Unboxed_float Pfloat64 -> K.naked_float | Unboxed_float Pfloat32 -> K.naked_float32 | Unboxed_integer Pnativeint -> K.naked_nativeint diff --git a/ocaml/bytecomp/bytegen.ml b/ocaml/bytecomp/bytegen.ml index 158ff6c6ced..83d02406278 100644 --- a/ocaml/bytecomp/bytegen.ml +++ b/ocaml/bytecomp/bytegen.ml @@ -381,6 +381,7 @@ let comp_primitive stack_info p sz args = | Pcompare_floats Pfloat32 -> Kccall("caml_float32_compare", 2) | Pcompare_bints bi -> comp_bint_primitive bi "compare" args | Pfield (n, _ptr, _sem) -> Kgetfield n + | Punboxed_product_field (n, _layouts) -> Kgetfield n | Pfield_computed _sem -> Kgetvectitem | Psetfield(n, _ptr, _init) -> Ksetfield n | Psetfield_computed(_ptr, _init) -> Ksetvectitem @@ -628,12 +629,12 @@ let comp_primitive stack_info p sz args = | Pmakearray _ | Pduparray _ | Pfloatcomp (_, _) | Punboxed_float_comp (_, _) | Pmakeblock _ + | Pmake_unboxed_product _ | Pmakefloatblock _ | Pmakeufloatblock _ | Pmakemixedblock _ | Pprobe_is_enabled _ | Punbox_float _ | Pbox_float (_, _) | Punbox_int _ | Pbox_int _ - | Pmake_unboxed_product _ | Punboxed_product_field _ -> fatal_error "Bytegen.comp_primitive" @@ -920,6 +921,10 @@ let rec comp_expr stack_info env exp sz cont = let cont = add_pseudo_event loc !compunit_name cont in comp_args stack_info env args sz (Kmakeblock(List.length args, tag) :: cont) + | Lprim(Pmake_unboxed_product _, args, loc) -> + let cont = add_pseudo_event loc !compunit_name cont in + comp_args stack_info env args sz + (Kmakeblock(List.length args, 0) :: cont) | Lprim(Pfloatfield (n, _, _), args, loc) -> let cont = add_pseudo_event loc !compunit_name cont in comp_args stack_info env args sz (Kgetfloatfield n :: cont) diff --git a/ocaml/file_formats/cmt_format.ml b/ocaml/file_formats/cmt_format.ml index d35877168fe..49ba7ed2ec6 100644 --- a/ocaml/file_formats/cmt_format.ml +++ b/ocaml/file_formats/cmt_format.ml @@ -219,7 +219,8 @@ let iter_on_occurrences | Texp_extension_constructor (lid, path) -> f ~namespace:Extension_constructor exp_env path lid | Texp_constant _ | Texp_let _ | Texp_function _ | Texp_apply _ - | Texp_match _ | Texp_try _ | Texp_tuple _ | Texp_variant _ | Texp_array _ + | Texp_match _ | Texp_try _ | Texp_tuple _ | Texp_unboxed_tuple _ + | Texp_variant _ | Texp_array _ | Texp_ifthenelse _ | Texp_sequence _ | Texp_while _ | Texp_for _ | Texp_send _ | Texp_letmodule _ | Texp_letexception _ | Texp_assert _ | Texp_lazy _ @@ -243,6 +244,7 @@ let iter_on_occurrences (* Deprecated syntax to extend a polymorphic variant *) f ~namespace:Type ctyp_env path lid | Ttyp_var _ | Ttyp_arrow _ | Ttyp_tuple _ | Ttyp_object _ + | Ttyp_unboxed_tuple _ | Ttyp_alias _ | Ttyp_variant _ | Ttyp_poly _ | Ttyp_call_pos -> ()); default_iterator.typ sub ct); @@ -268,6 +270,7 @@ let iter_on_occurrences add_label pat_env lid label_descr) fields | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_constant _ | Tpat_tuple _ + | Tpat_unboxed_tuple _ | Tpat_variant _ | Tpat_array _ | Tpat_lazy _ | Tpat_value _ | Tpat_exception _ | Tpat_or _ -> ()); List.iter (fun (pat_extra, _, _) -> diff --git a/ocaml/lambda/lambda.ml b/ocaml/lambda/lambda.ml index 52b2bdaf251..9dc893dc792 100644 --- a/ocaml/lambda/lambda.ml +++ b/ocaml/lambda/lambda.ml @@ -334,7 +334,7 @@ type primitive = | Pdls_get and extern_repr = - | Same_as_ocaml_repr of Jkind.Sort.const + | Same_as_ocaml_repr of Jkind.Sort.base | Unboxed_float of boxed_float | Unboxed_vector of Primitive.boxed_vector | Unboxed_integer of Primitive.boxed_integer diff --git a/ocaml/lambda/lambda.mli b/ocaml/lambda/lambda.mli index 52b93fb0717..02a52c91cc4 100644 --- a/ocaml/lambda/lambda.mli +++ b/ocaml/lambda/lambda.mli @@ -336,7 +336,7 @@ type primitive = (** This is the same as [Primitive.native_repr] but with [Repr_poly] compiled away. *) and extern_repr = - | Same_as_ocaml_repr of Jkind.Sort.const + | Same_as_ocaml_repr of Jkind.Sort.base | Unboxed_float of boxed_float | Unboxed_vector of Primitive.boxed_vector | Unboxed_integer of Primitive.boxed_integer diff --git a/ocaml/lambda/matching.ml b/ocaml/lambda/matching.ml index edb6fd87f0b..cc73100cb93 100644 --- a/ocaml/lambda/matching.ml +++ b/ocaml/lambda/matching.ml @@ -106,11 +106,18 @@ exception Error of Location.t * error let dbg = false let jkind_layout_default_to_value_and_check_not_void loc jkind = + let rec contains_void : Jkind.Layout.Const.t -> bool = function + | Any -> false + | Base Void -> true + | Base (Value | Float64 | Float32 | Word | Bits32 | Bits64) -> false + | Product [] -> + Misc.fatal_error "nil in jkind_layout_default_to_value_and_check_not_void" + | Product ts -> List.exists contains_void ts + in let const = Jkind.default_to_value_and_get jkind in let layout = Jkind.Const.get_layout const in - match layout with - | Sort Void -> raise (Error (loc, Void_layout)) - | _ -> () + if contains_void layout then + raise (Error (loc, Void_layout)) ;; (* @@ -261,8 +268,8 @@ end = struct | `Or _ as or_view -> stop orpat or_view | other_view -> continue orpat other_view ) - | ( `Constant _ | `Tuple _ | `Construct _ | `Variant _ | `Array _ - | `Lazy _ ) as view -> + | ( `Constant _ | `Tuple _ | `Unboxed_tuple _ | `Construct _ | `Variant _ + | `Array _ | `Lazy _ ) as view -> stop p view in aux cl @@ -299,6 +306,9 @@ end = struct | `Constant cst -> `Constant cst | `Tuple ps -> `Tuple (List.map (fun (label, p) -> label, alpha_pat env p) ps) + | `Unboxed_tuple ps -> + `Unboxed_tuple + (List.map (fun (label, p, sort) -> label, alpha_pat env p, sort) ps) | `Construct (cstr, cst_descr, args) -> `Construct (cstr, cst_descr, List.map (alpha_pat env) args) | `Variant (cstr, argo, row_desc) -> @@ -437,42 +447,27 @@ let matcher discr (p : Simple.pattern) rem = match (discr.pat_desc, ph.pat_desc) with | Any, _ -> rem | ( ( Constant _ | Construct _ | Variant _ | Lazy | Array _ | Record _ - | Tuple _ ), + | Tuple _ | Unboxed_tuple _ ), Any ) -> omegas @ rem | Constant cst, Constant cst' -> yesif (const_compare cst cst' = 0) - | Constant _, (Construct _ | Variant _ | Lazy | Array _ | Record _ | Tuple _) - -> - no () | Construct cstr, Construct cstr' -> (* NB: may_equal_constr considers (potential) constructor rebinding; Types.may_equal_constr does check that the arities are the same, preserving row-size coherence. *) yesif (Types.may_equal_constr cstr cstr') - | Construct _, (Constant _ | Variant _ | Lazy | Array _ | Record _ | Tuple _) - -> - no () | Variant { tag; has_arg }, Variant { tag = tag'; has_arg = has_arg' } -> yesif (tag = tag' && has_arg = has_arg') - | Variant _, (Constant _ | Construct _ | Lazy | Array _ | Record _ | Tuple _) - -> - no () | Array (am1, _, n1), Array (am2, _, n2) -> yesif (am1 = am2 && n1 = n2) - | Array _, (Constant _ | Construct _ | Variant _ | Lazy | Record _ | Tuple _) - -> - no () | Tuple n1, Tuple n2 -> yesif (n1 = n2) - | Tuple _, (Constant _ | Construct _ | Variant _ | Lazy | Array _ | Record _) - -> - no () + | Unboxed_tuple l1, Unboxed_tuple l2 -> + yesif (List.for_all2 (fun (lbl1, _) (lbl2, _) -> lbl1 = lbl2) l1 l2) | Record l, Record l' -> (* we already expanded the record fully *) yesif (List.length l = List.length l') - | Record _, (Constant _ | Construct _ | Variant _ | Lazy | Array _ | Tuple _) - -> - no () | Lazy, Lazy -> yes () - | Lazy, (Constant _ | Construct _ | Variant _ | Array _ | Record _ | Tuple _) + | ( Constant _ | Construct _ | Variant _ | Lazy | Array _ | Record _ | Tuple _ + | Unboxed_tuple _), _ -> no () @@ -1180,6 +1175,7 @@ let can_group discr pat = Types.equal_tag discr_tag pat_cstr.cstr_tag | Construct _, Construct _ | Tuple _, (Tuple _ | Any) + | Unboxed_tuple _, (Unboxed_tuple _ | Any) | Record _, (Record _ | Any) | Array _, Array _ | Variant _, Variant _ @@ -1193,7 +1189,8 @@ let can_group discr pat = | Const_int32 _ | Const_int64 _ | Const_nativeint _ | Const_unboxed_int32 _ | Const_unboxed_int64 _ | Const_unboxed_nativeint _ ) - | Construct _ | Tuple _ | Record _ | Array _ | Variant _ | Lazy ) ) -> + | Construct _ | Tuple _ | Unboxed_tuple _ | Record _ | Array _ + | Variant _ | Lazy ) ) -> false let is_or p = @@ -2098,6 +2095,13 @@ let get_pat_args_tuple arity p rem = | { pat_desc = Tpat_tuple args } -> (List.map snd args) @ rem | _ -> assert false +let get_pat_args_unboxed_tuple arity p rem = + match p with + | { pat_desc = Tpat_any } -> Patterns.omegas arity @ rem + | { pat_desc = Tpat_unboxed_tuple args } -> + (List.map (fun (_, p, _) -> p) args) @ rem + | _ -> assert false + let get_expr_args_tuple ~scopes head (arg, _mut, _sort, _layout) rem = let loc = head_loc ~scopes head in let arity = Patterns.Head.arity head in @@ -2111,6 +2115,24 @@ let get_expr_args_tuple ~scopes head (arg, _mut, _sort, _layout) rem = in make_args 0 +let get_expr_args_unboxed_tuple ~scopes shape head (arg, _mut, _sort, _layout) + rem = + let loc = head_loc ~scopes head in + let shape = + List.map (fun (_, sort) -> + sort, + (* CR layouts v7.1: consider whether more accurate [Lambda.layout]s here + would make a difference for later optimizations. *) + Typeopt.layout_of_sort (Scoped_location.to_location loc) sort + ) shape + in + let layouts = List.map (fun (_, layout) -> layout) shape in + List.mapi (fun pos (sort, layout) -> + (Lprim (Punboxed_product_field (pos, layouts), [ arg ], loc), Alias, + sort, layout)) + shape + @ rem + let divide_tuple ~scopes head ctx pm = let arity = Patterns.Head.arity head in divide_line (Context.specialize head) @@ -2118,6 +2140,13 @@ let divide_tuple ~scopes head ctx pm = (get_pat_args_tuple arity) head ctx pm +let divide_unboxed_tuple ~scopes head shape ctx pm = + let arity = Patterns.Head.arity head in + divide_line (Context.specialize head) + (get_expr_args_unboxed_tuple ~scopes shape) + (get_pat_args_unboxed_tuple arity) + head ctx pm + (* Matching against a record pattern *) let record_matching_line num_fields lbl_pat_list = @@ -3582,6 +3611,10 @@ and do_compile_matching ~scopes value_kind repr partial ctx pmh = compile_no_test ~scopes value_kind (divide_tuple ~scopes ph) Context.combine repr partial ctx pm + | Unboxed_tuple shape -> + compile_no_test ~scopes value_kind + (divide_unboxed_tuple ~scopes ph shape) + Context.combine repr partial ctx pm | Record [] -> assert false | Record (lbl :: _) -> compile_no_test ~scopes value_kind @@ -3663,6 +3696,7 @@ let is_lazy_pat p = | Tpat_variant _ | Tpat_record _ | Tpat_tuple _ + | Tpat_unboxed_tuple _ | Tpat_construct _ | Tpat_array _ | Tpat_or _ @@ -3683,6 +3717,7 @@ let is_record_with_mutable_field p = | Tpat_variant _ | Tpat_lazy _ | Tpat_tuple _ + | Tpat_unboxed_tuple _ | Tpat_construct _ | Tpat_array _ | Tpat_or _ @@ -4024,7 +4059,8 @@ let flatten_simple_pattern size (p : Simple.pattern) = | `Record _ | `Lazy _ | `Construct _ - | `Constant _ -> + | `Constant _ + | `Unboxed_tuple _ -> (* All calls to this function originate from [do_for_multiple_match], where we know that the scrutinee is a tuple literal. diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml index 68e97db9cff..f5f48a60c6d 100644 --- a/ocaml/lambda/translcore.ml +++ b/ocaml/lambda/translcore.ml @@ -31,6 +31,7 @@ type error = | Unreachable_reached | Bad_probe_layout of Ident.t | Illegal_void_record_field + | Illegal_product_record_field of Jkind.Sort.Const.t | Void_sort of type_expr exception Error of Location.t * error @@ -55,8 +56,9 @@ let layout_pat sort p = layout p.pat_env p.pat_loc sort p.pat_type let check_record_field_sort loc sort = match Jkind.Sort.default_to_value_and_get sort with - | Value | Float64 | Float32 | Bits32 | Bits64 | Word -> () - | Void -> raise (Error (loc, Illegal_void_record_field)) + | Base (Value | Float64 | Float32 | Bits32 | Bits64 | Word) -> () + | Base Void -> raise (Error (loc, Illegal_void_record_field)) + | Product _ as c -> raise (Error (loc, Illegal_product_record_field c)) (* Forward declaration -- to be filled in by Translmod.transl_module *) let transl_module = @@ -428,8 +430,9 @@ and transl_exp0 ~in_new_scope ~scopes sort e = | ((_, arg_repr) :: prim_repr), ((_, Arg (x, _)) :: oargs) -> let arg_exps, extra_args = cut_args prim_repr oargs in let arg_sort = - Jkind.Sort.of_const - (Translprim.sort_of_native_repr arg_repr ~poly_sort:psort) + Jkind.Sort.of_base + (Translprim.sort_of_native_repr ~loc:x.exp_loc arg_repr + ~poly_sort:psort) in (x, arg_sort) :: arg_exps, extra_args | _, ((_, Omitted _) :: _) -> assert false @@ -510,6 +513,12 @@ and transl_exp0 ~in_new_scope ~scopes sort e = ll, (of_location ~scopes e.exp_loc)) end + | Texp_unboxed_tuple el -> + let shape = List.map (fun (_, e, s) -> layout_exp s e) el in + let ll = List.map (fun (_, e, s) -> transl_exp ~scopes s e) el in + Lprim(Pmake_unboxed_product shape, + ll, + of_location ~scopes e.exp_loc) | Texp_construct(_, cstr, args, alloc_mode) -> let args_with_sorts = List.mapi (fun i e -> @@ -2094,6 +2103,11 @@ and transl_match ~scopes ~arg_sort ~return_sort e arg pat_expr_list partial = let classic = match arg, exn_cases with | {exp_desc = Texp_tuple (argl, alloc_mode)}, [] -> + (* CR layouts v7.1: This case and the one below it give special treatment + to matching on literal tuples. This optimization is irrelevant for + unboxed tuples in native code, but not doing it for unboxed tuples in + bytecode means unboxed tuple are slightly worse than normal tuples + there. Consider adding it for unboxed tuples. *) assert (static_handlers = []); let mode = transl_alloc_mode alloc_mode in let argl = @@ -2256,6 +2270,11 @@ let report_error ppf = function fprintf ppf "Void sort detected where value was expected in a record field:@ Please \ report this error to the Jane Street compilers team." + | Illegal_product_record_field c -> + fprintf ppf + "Product sort %a detected in a record field:@ Please \ + report this error to the Jane Street compilers team." + Jkind.Sort.Const.format c | Void_sort ty -> fprintf ppf "Void detected in translation for type %a:@ Please report this error \ diff --git a/ocaml/lambda/translcore.mli b/ocaml/lambda/translcore.mli index ebe5190f714..fb812b3e768 100644 --- a/ocaml/lambda/translcore.mli +++ b/ocaml/lambda/translcore.mli @@ -49,6 +49,7 @@ type error = | Unreachable_reached | Bad_probe_layout of Ident.t | Illegal_void_record_field + | Illegal_product_record_field of Jkind.Sort.Const.t | Void_sort of Types.type_expr exception Error of Location.t * error diff --git a/ocaml/lambda/translprim.ml b/ocaml/lambda/translprim.ml index 304c926260d..f9d630467da 100644 --- a/ocaml/lambda/translprim.ml +++ b/ocaml/lambda/translprim.ml @@ -29,6 +29,7 @@ type error = | Unknown_builtin_primitive of string | Wrong_arity_builtin_primitive of string | Invalid_floatarray_glb + | Unexpected_product_in_prim of Jkind.Sort.Const.t exception Error of Location.t * error @@ -144,9 +145,14 @@ let to_modify_mode ~poly = function | Some mode -> transl_modify_mode mode let extern_repr_of_native_repr: - poly_sort:Jkind.Sort.t option -> Primitive.native_repr -> Lambda.extern_repr - = fun ~poly_sort r -> match r, poly_sort with - | Repr_poly, Some s -> Same_as_ocaml_repr (Jkind.Sort.default_to_value_and_get s) + loc:_ -> poly_sort:Jkind.Sort.t option -> Primitive.native_repr + -> Lambda.extern_repr + = fun ~loc ~poly_sort r -> match r, poly_sort with + | Repr_poly, Some s -> + begin match Jkind.Sort.default_to_value_and_get s with + | Base b -> Same_as_ocaml_repr b + | Product _ as c -> raise (Error (loc, Unexpected_product_in_prim c)) + end | Repr_poly, None -> Misc.fatal_error "Unexpected Repr_poly" | Same_as_ocaml_repr s, _ -> Same_as_ocaml_repr s | Unboxed_float f, _ -> Unboxed_float f @@ -154,22 +160,22 @@ let extern_repr_of_native_repr: | Unboxed_vector i, _ -> Unboxed_vector i | Untagged_int, _ -> Untagged_int -let sort_of_native_repr ~poly_sort repr = - match extern_repr_of_native_repr ~poly_sort repr with +let sort_of_native_repr ~loc ~poly_sort repr = + match extern_repr_of_native_repr ~loc ~poly_sort repr with | Same_as_ocaml_repr s -> s | (Unboxed_float _ | Unboxed_integer _ | Untagged_int | Unboxed_vector _) -> Jkind.Sort.Value -let to_lambda_prim prim ~poly_sort = +let to_lambda_prim ~loc prim ~poly_sort = let native_repr_args = List.map - (fun (m, r) -> m, extern_repr_of_native_repr ~poly_sort r) + (fun (m, r) -> m, extern_repr_of_native_repr ~loc ~poly_sort r) prim.prim_native_repr_args in let native_repr_res = let (m, r) = prim.prim_native_repr_res in - m, extern_repr_of_native_repr ~poly_sort r + m, extern_repr_of_native_repr ~loc ~poly_sort r in Primitive.make ~name:prim.prim_name @@ -326,7 +332,7 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p = Misc.fatal_errorf "Primitive \"%s\" unexpectedly had zero arguments" p.prim_name in - let lambda_prim = to_lambda_prim p ~poly_sort in + let lambda_prim = to_lambda_prim ~loc p ~poly_sort in let layout = (* Extract the result layout of the primitive. This can be a non-value layout even without the use of [@layout_poly]. For example: @@ -1368,7 +1374,7 @@ let check_primitive_arity loc p = in (* By a similar assumption, the sort shouldn't change the arity. So it's ok to lie here. *) - let sort = Some (Jkind.Sort.of_const Value) in + let sort = Some (Jkind.Sort.of_base Value) in let prim = lookup_primitive loc ~poly_mode:mode ~poly_sort:sort Rc_normal p in @@ -1405,13 +1411,15 @@ let transl_primitive loc p env ty ~poly_mode ~poly_sort path = | Some prim -> prim in let to_locality = to_locality ~poly:poly_mode in + let error_loc = to_location loc in let rec make_params ty repr_args repr_res = match repr_args, repr_res with | [], (_, res_repr) -> let res_sort = - Jkind.Sort.of_const (sort_of_native_repr res_repr ~poly_sort) + Jkind.Sort.of_base + (sort_of_native_repr ~loc:error_loc res_repr ~poly_sort) in - [], Typeopt.layout env (to_location loc) res_sort ty + [], Typeopt.layout env error_loc res_sort ty | (((_, arg_repr) as arg) :: repr_args), _ -> match Typeopt.is_function_type env ty with | None -> @@ -1419,10 +1427,11 @@ let transl_primitive loc p env ty ~poly_mode ~poly_sort path = (Primitive.byte_name p) | Some (arg_ty, ret_ty) -> let arg_sort = - Jkind.Sort.of_const (sort_of_native_repr arg_repr ~poly_sort) + Jkind.Sort.of_base + (sort_of_native_repr ~loc:error_loc arg_repr ~poly_sort) in let arg_layout = - Typeopt.layout env (to_location loc) arg_sort arg_ty + Typeopt.layout env error_loc arg_sort arg_ty in let arg_mode = to_locality arg in let params, return = make_params ret_ty repr_args repr_res in @@ -1625,7 +1634,12 @@ let report_error ppf = function | Invalid_floatarray_glb -> fprintf ppf "@[Floatarray primitives can't be used on arrays containing@ \ - unboxed types.@]" + unboxed types.@]" + | Unexpected_product_in_prim c -> + fprintf ppf + "@[Unboxed product layouts are not yet supported as arguments to@ \ + layout polymorphic externals.@ The layout of this argument is %a.@]" + Jkind.Sort.Const.format c let () = Location.register_error_of_exn (function diff --git a/ocaml/lambda/translprim.mli b/ocaml/lambda/translprim.mli index e4b3c5a81f7..359b26b483e 100644 --- a/ocaml/lambda/translprim.mli +++ b/ocaml/lambda/translprim.mli @@ -55,8 +55,8 @@ val transl_primitive_application : [poly_sort] must be [Some sort] when [Repr_poly] is given. It will produce fatal error if it's [None]. *) val sort_of_native_repr : - poly_sort:Jkind.Sort.t option -> - Primitive.native_repr -> Jkind.Sort.const + loc:Location.t -> poly_sort:Jkind.Sort.t option -> + Primitive.native_repr -> Jkind.Sort.base (* Errors *) @@ -64,6 +64,7 @@ type error = | Unknown_builtin_primitive of string | Wrong_arity_builtin_primitive of string | Invalid_floatarray_glb + | Unexpected_product_in_prim of Jkind.Sort.Const.t exception Error of Location.t * error diff --git a/ocaml/ocamldoc/odoc_misc.ml b/ocaml/ocamldoc/odoc_misc.ml index a1898c10725..99a97ad578e 100644 --- a/ocaml/ocamldoc/odoc_misc.ml +++ b/ocaml/ocamldoc/odoc_misc.ml @@ -501,6 +501,7 @@ let remove_option typ = | Tpoly _ | Tarrow _ | Ttuple _ + | Tunboxed_tuple _ | Tobject _ | Tfield _ | Tnil diff --git a/ocaml/ocamldoc/odoc_str.ml b/ocaml/ocamldoc/odoc_str.ml index 5c413dab796..2f93765b21b 100644 --- a/ocaml/ocamldoc/odoc_str.ml +++ b/ocaml/ocamldoc/odoc_str.ml @@ -40,6 +40,7 @@ let rec is_arrow_type t = Types.Tarrow _ -> true | Types.Tlink t2 -> is_arrow_type t2 | Types.Ttuple _ + | Types.Tunboxed_tuple _ | Types.Tconstr _ | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _ | Types.Tfield _ | Types.Tnil | Types.Tvariant _ | Types.Tpackage _ -> false @@ -48,7 +49,7 @@ let rec is_arrow_type t = let rec need_parent t = match Types.get_desc t with - Types.Tarrow _ | Types.Ttuple _ -> true + Types.Tarrow _ | Types.Ttuple _ | Tunboxed_tuple _ -> true | Types.Tlink t2 -> need_parent t2 | Types.Tconstr _ | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _ diff --git a/ocaml/ocamldoc/odoc_value.ml b/ocaml/ocamldoc/odoc_value.ml index dbfcd265500..4fcb5743974 100644 --- a/ocaml/ocamldoc/odoc_value.ml +++ b/ocaml/ocamldoc/odoc_value.ml @@ -69,6 +69,7 @@ let parameter_list_from_arrows typ = | Types.Tpoly (texp, _) -> iter texp | Types.Tvar _ | Types.Ttuple _ + | Types.Tunboxed_tuple _ | Types.Tconstr _ | Types.Tobject _ | Types.Tfield _ diff --git a/ocaml/parsing/ast_helper.ml b/ocaml/parsing/ast_helper.ml index bf02ab63cdb..83d68b2aaec 100644 --- a/ocaml/parsing/ast_helper.ml +++ b/ocaml/parsing/ast_helper.ml @@ -64,6 +64,7 @@ module Typ = struct let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) let arrow ?loc ?attrs a b c d e = mk ?loc ?attrs (Ptyp_arrow (a, b, c, d, e)) let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) + let unboxed_tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_unboxed_tuple a) let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) @@ -99,6 +100,8 @@ module Typ = struct | Ptyp_arrow (label,core_type,core_type',modes,modes') -> Ptyp_arrow(label, loop core_type, loop core_type', modes, modes') | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) + | Ptyp_unboxed_tuple lst -> + Ptyp_unboxed_tuple (List.map (fun (l, t) -> l, loop t) lst) | Ptyp_constr( { txt = Longident.Lident s }, []) when List.mem s var_names -> Ptyp_var s @@ -163,6 +166,7 @@ module Pat = struct let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) + let unboxed_tuple ?loc ?attrs a b = mk ?loc ?attrs (Ppat_unboxed_tuple (a, b)) let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) @@ -193,6 +197,7 @@ module Exp = struct let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) + let unboxed_tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_unboxed_tuple a) let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) diff --git a/ocaml/parsing/ast_helper.mli b/ocaml/parsing/ast_helper.mli index d9d93c2f189..f6ea4f2a229 100644 --- a/ocaml/parsing/ast_helper.mli +++ b/ocaml/parsing/ast_helper.mli @@ -73,6 +73,8 @@ module Typ : val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type -> mode with_loc list -> mode with_loc list -> core_type val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type + val unboxed_tuple: ?loc:loc -> ?attrs:attrs + -> (string option * core_type) list -> core_type val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type val object_: ?loc:loc -> ?attrs:attrs -> object_field list -> closed_flag -> core_type @@ -110,6 +112,9 @@ module Pat: val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + val unboxed_tuple: ?loc:loc -> ?attrs:attrs + -> (string option * pattern) list -> closed_flag + -> pattern val construct: ?loc:loc -> ?attrs:attrs -> lid -> (str list * pattern) option -> pattern val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern @@ -146,6 +151,8 @@ module Exp: -> expression val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression + val unboxed_tuple: ?loc:loc -> ?attrs:attrs + -> (string option * expression) list -> expression val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option -> expression val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option diff --git a/ocaml/parsing/ast_iterator.ml b/ocaml/parsing/ast_iterator.ml index 3082e0d0eef..7e7751592cc 100644 --- a/ocaml/parsing/ast_iterator.ml +++ b/ocaml/parsing/ast_iterator.ml @@ -100,8 +100,6 @@ let iter_loc_txt sub f { loc; txt } = module T = struct (* Type expressions for the core language *) - module LT = Jane_syntax.Labeled_tuples - let row_field sub { prf_desc; prf_loc; @@ -141,12 +139,11 @@ module T = struct sub.typ sub aliased_type; iter_loc_txt sub sub.jkind_annotation jkind - let iter_jst_labeled_tuple sub : LT.core_type -> _ = function - | tl -> List.iter (iter_snd (sub.typ sub)) tl + let iter_labeled_tuple sub tl = List.iter (iter_snd (sub.typ sub)) tl let iter_jst sub : Jane_syntax.Core_type.t -> _ = function | Jtyp_layout typ -> iter_jst_layout sub typ - | Jtyp_tuple lt_typ -> iter_jst_labeled_tuple sub lt_typ + | Jtyp_tuple lt_typ -> iter_labeled_tuple sub lt_typ let iter sub ({ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} as typ) = @@ -164,6 +161,7 @@ module T = struct sub.typ sub t1; sub.typ sub t2; sub.modes sub m1; sub.modes sub m2 | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl + | Ptyp_unboxed_tuple tyl -> iter_labeled_tuple sub tyl | Ptyp_constr (lid, tl) -> iter_loc sub lid; List.iter (sub.typ sub) tl | Ptyp_object (ol, _o) -> @@ -464,7 +462,6 @@ module E = struct module C = Jane_syntax.Comprehensions module IA = Jane_syntax.Immutable_arrays module L = Jane_syntax.Layouts - module LT = Jane_syntax.Labeled_tuples let iter_iterator sub : C.iterator -> _ = function | Range { start; stop; direction = _ } -> @@ -533,8 +530,7 @@ module E = struct sub.location sub loc; sub.attributes sub attrs - let iter_labeled_tuple sub : LT.expression -> _ = function - | el -> List.iter (iter_snd (sub.expr sub)) el + let iter_labeled_tuple sub el = List.iter (iter_snd (sub.expr sub)) el let iter_jst sub : Jane_syntax.Expression.t -> _ = function | Jexp_comprehension comp_exp -> iter_comp_exp sub comp_exp @@ -567,6 +563,7 @@ module E = struct sub.expr sub e; sub.cases sub pel | Pexp_try (e, pel) -> sub.expr sub e; sub.cases sub pel | Pexp_tuple el -> List.iter (sub.expr sub) el + | Pexp_unboxed_tuple el -> iter_labeled_tuple sub el | Pexp_construct (lid, arg) -> iter_loc sub lid; iter_opt (sub.expr sub) arg | Pexp_variant (_lab, eo) -> @@ -638,20 +635,17 @@ module P = struct (* Patterns *) module IA = Jane_syntax.Immutable_arrays - module LT = Jane_syntax.Labeled_tuples let iter_iapat sub : IA.pattern -> _ = function | Iapat_immutable_array elts -> List.iter (sub.pat sub) elts - let iter_labeled_tuple sub : LT.pattern -> _ = function - | (pl, _) -> - List.iter (iter_snd (sub.pat sub)) pl + let iter_labeled_tuple sub pl = List.iter (iter_snd (sub.pat sub)) pl let iter_jst sub : Jane_syntax.Pattern.t -> _ = function | Jpat_immutable_array iapat -> iter_iapat sub iapat | Jpat_layout (Lpat_constant _) -> iter_constant - | Jpat_tuple ltpat -> iter_labeled_tuple sub ltpat + | Jpat_tuple (ltpat, _) -> iter_labeled_tuple sub ltpat let iter sub ({ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} as pat) = @@ -669,6 +663,7 @@ module P = struct | Ppat_constant _ -> iter_constant | Ppat_interval _ -> () | Ppat_tuple pl -> List.iter (sub.pat sub) pl + | Ppat_unboxed_tuple (pl, _) -> iter_labeled_tuple sub pl | Ppat_construct (l, p) -> iter_loc sub l; iter_opt @@ -956,5 +951,6 @@ let default_iterator = | With (t, ty) -> this.jkind_annotation this t; this.typ this ty - | Kind_of ty -> this.typ this ty); + | Kind_of ty -> this.typ this ty + | Product ts -> List.iter (this.jkind_annotation this) ts); } diff --git a/ocaml/parsing/ast_mapper.ml b/ocaml/parsing/ast_mapper.ml index 006185414ff..f4f6a8b8c75 100644 --- a/ocaml/parsing/ast_mapper.ml +++ b/ocaml/parsing/ast_mapper.ml @@ -122,8 +122,6 @@ end module T = struct (* Type expressions for the core language *) - module LT = Jane_syntax.Labeled_tuples - let row_field sub { prf_desc; prf_loc; @@ -174,14 +172,13 @@ module T = struct let jkind = map_loc_txt sub sub.jkind_annotation jkind in Ltyp_alias { aliased_type; name; jkind } - let map_jst_labeled_tuple sub : LT.core_type -> LT.core_type = function + let map_labeled_tuple sub tl = List.map (map_snd (sub.typ sub)) tl (* CR labeled tuples: Eventually mappers may want to see the labels. *) - | tl -> List.map (map_snd (sub.typ sub)) tl let map_jst sub : Jane_syntax.Core_type.t -> Jane_syntax.Core_type.t = function | Jtyp_layout typ -> Jtyp_layout (map_jst_layouts sub typ) - | Jtyp_tuple x -> Jtyp_tuple (map_jst_labeled_tuple sub x) + | Jtyp_tuple x -> Jtyp_tuple (map_labeled_tuple sub x) let map sub ({ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} as typ) = @@ -201,6 +198,8 @@ module T = struct | Ptyp_arrow (lab, t1, t2, m1, m2) -> arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) (sub.modes sub m1) (sub.modes sub m2) | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) + | Ptyp_unboxed_tuple tyl -> + unboxed_tuple ~loc ~attrs (map_labeled_tuple sub tyl) | Ptyp_constr (lid, tl) -> constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) | Ptyp_object (l, o) -> @@ -549,7 +548,6 @@ module E = struct module C = Jane_syntax.Comprehensions module IA = Jane_syntax.Immutable_arrays module L = Jane_syntax.Layouts - module LT = Jane_syntax.Labeled_tuples let map_function_param sub { pparam_loc = loc; pparam_desc = desc } = let loc = sub.location sub loc in @@ -628,9 +626,8 @@ module E = struct let inner_expr = sub.expr sub inner_expr in Lexp_newtype (str, jkind, inner_expr) - let map_ltexp sub : LT.expression -> LT.expression = function + let map_ltexp sub el = List.map (map_snd (sub.expr sub)) el (* CR labeled tuples: Eventually mappers may want to see the labels. *) - | el -> List.map (map_snd (sub.expr sub)) el let map_jst sub : Jane_syntax.Expression.t -> Jane_syntax.Expression.t = function @@ -668,6 +665,8 @@ module E = struct match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) + | Pexp_unboxed_tuple el -> + unboxed_tuple ~loc ~attrs (map_ltexp sub el) | Pexp_construct (lid, arg) -> construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) | Pexp_variant (lab, eo) -> @@ -743,7 +742,6 @@ module P = struct module IA = Jane_syntax.Immutable_arrays module L = Jane_syntax.Layouts - module LT = Jane_syntax.Labeled_tuples let map_iapat sub : IA.pattern -> IA.pattern = function | Iapat_immutable_array elts -> @@ -755,16 +753,14 @@ module P = struct *) | Float _ | Integer _ as x -> x - let map_ltpat sub : LT.pattern -> LT.pattern = function + let map_ltpat sub pl = List.map (map_snd (sub.pat sub)) pl (* CR labeled tuples: Eventually mappers may want to see the labels. *) - | (pl, closed) -> - (List.map (map_snd (sub.pat sub)) pl, closed) let map_jst sub : Jane_syntax.Pattern.t -> Jane_syntax.Pattern.t = function | Jpat_immutable_array x -> Jpat_immutable_array (map_iapat sub x) | Jpat_layout (Lpat_constant x) -> Jpat_layout (Lpat_constant (map_unboxed_constant_pat sub x)) - | Jpat_tuple ltpat -> Jpat_tuple (map_ltpat sub ltpat) + | Jpat_tuple (ltpat, c) -> Jpat_tuple (map_ltpat sub ltpat, c) let map sub ({ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} as pat) = @@ -785,6 +781,8 @@ module P = struct | Ppat_interval (c1, c2) -> interval ~loc ~attrs (sub.constant sub c1) (sub.constant sub c2) | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) + | Ppat_unboxed_tuple (pl, c) -> + unboxed_tuple ~loc ~attrs (map_ltpat sub pl) c | Ppat_construct (l, p) -> construct ~loc ~attrs (map_loc sub l) (map_opt @@ -1087,7 +1085,8 @@ let default_mapper = Mod (this.jkind_annotation this t, this.modes this mode_list) | With (t, ty) -> With (this.jkind_annotation this t, this.typ this ty) - | Kind_of ty -> Kind_of (this.typ this ty)); + | Kind_of ty -> Kind_of (this.typ this ty) + | Product ts -> Product (List.map (this.jkind_annotation this) ts)); expr_jane_syntax = E.map_jst; extension_constructor_jane_syntax = T.map_extension_constructor_jst; diff --git a/ocaml/parsing/depend.ml b/ocaml/parsing/depend.ml index 4332b483007..9922490dccc 100644 --- a/ocaml/parsing/depend.ml +++ b/ocaml/parsing/depend.ml @@ -112,6 +112,7 @@ let rec add_type bv ty = | Ptyp_var _ -> () | Ptyp_arrow(_, t1, t2, _, _) -> add_type bv t1; add_type bv t2 | Ptyp_tuple tl -> List.iter (add_type bv) tl + | Ptyp_unboxed_tuple tl -> add_type_labeled_tuple bv tl | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl | Ptyp_object (fl, _) -> List.iter @@ -132,7 +133,7 @@ let rec add_type bv ty = and add_type_jst bv : Jane_syntax.Core_type.t -> _ = function | Jtyp_layout typ -> add_type_jst_layouts bv typ - | Jtyp_tuple x -> add_type_jst_labeled_tuple bv x + | Jtyp_tuple x -> add_type_labeled_tuple bv x and add_type_jst_layouts bv : Jane_syntax.Layouts.core_type -> _ = function | Ltyp_var { name = _; jkind } -> @@ -144,8 +145,8 @@ and add_type_jst_layouts bv : Jane_syntax.Layouts.core_type -> _ = function add_type bv aliased_type; add_jkind bv jkind -and add_type_jst_labeled_tuple bv : Jane_syntax.Labeled_tuples.core_type -> _ = - fun tl -> List.iter (fun (_, ty) -> add_type bv ty) tl +and add_type_labeled_tuple bv tl = + List.iter (fun (_, ty) -> add_type bv ty) tl and add_package_type bv (lid, l) = add bv lid; @@ -218,6 +219,7 @@ let rec add_pattern bv pat = | Ppat_interval _ | Ppat_constant _ -> () | Ppat_tuple pl -> List.iter (add_pattern bv) pl + | Ppat_unboxed_tuple (pl, _)-> add_pattern_labeled_tuple bv pl | Ppat_construct(c, opt) -> add bv c; add_opt @@ -243,8 +245,10 @@ and add_pattern_jane_syntax bv : Jane_syntax.Pattern.t -> _ = function | Jpat_immutable_array (Iapat_immutable_array pl) -> List.iter (add_pattern bv) pl | Jpat_layout (Lpat_constant _) -> add_constant - | Jpat_tuple (labeled_pl, _) -> - List.iter (fun (_, p) -> add_pattern bv p) labeled_pl + | Jpat_tuple (labeled_pl, _) -> add_pattern_labeled_tuple bv labeled_pl + +and add_pattern_labeled_tuple bv labeled_pl = + List.iter (fun (_, p) -> add_pattern bv p) labeled_pl let add_pattern bv pat = pattern_bv := bv; @@ -269,6 +273,7 @@ let rec add_expr bv exp = | Pexp_match(e, pel) -> add_expr bv e; add_cases bv pel | Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel | Pexp_tuple el -> List.iter (add_expr bv) el + | Pexp_unboxed_tuple el -> add_labeled_tuple_expr bv el | Pexp_construct(c, opte) -> add bv c; add_opt add_expr bv opte | Pexp_variant(_, opte) -> add_opt add_expr bv opte | Pexp_record(lblel, opte) -> @@ -382,8 +387,7 @@ and add_layout_expr bv : Jane_syntax.Layouts.expression -> _ = function add_jkind bv jkind; add_expr bv inner_expr -and add_labeled_tuple_expr bv : Jane_syntax.Labeled_tuples.expression -> _ = - function el -> List.iter (add_expr bv) (List.map snd el) +and add_labeled_tuple_expr bv el = List.iter (add_expr bv) (List.map snd el) and add_function_param bv param = match param.pparam_desc with diff --git a/ocaml/parsing/jane_syntax.ml b/ocaml/parsing/jane_syntax.ml index 9debb1057ac..613b85b9aec 100644 --- a/ocaml/parsing/jane_syntax.ml +++ b/ocaml/parsing/jane_syntax.ml @@ -391,6 +391,7 @@ module Jkind = struct | Mod of t * modes | With of t * core_type | Kind_of of core_type + | Product of t list type annotation = t loc @@ -461,6 +462,8 @@ module Jkind = struct t_loc.loc | Kind_of ty -> struct_item_of_list "kind_of" [struct_item_of_type ty] t_loc.loc + | Product ts -> + struct_item_of_list "product" (List.map to_structure_item ts) t_loc.loc let rec of_structure_item item = let bind = Option.bind in @@ -480,6 +483,9 @@ module Jkind = struct bind (struct_item_to_type item_of_ty) (fun ty -> ret loc (Kind_of ty)) | Some ("abbrev", [item], loc) -> bind (Const.of_structure_item item) (fun c -> ret loc (Abbreviation c)) + | Some ("product", items, loc) -> + bind (Misc.Stdlib.List.map_option of_structure_item items) (fun tls -> + ret loc (Product (List.map (fun tl -> tl.txt) tls))) | Some _ | None -> None end diff --git a/ocaml/parsing/jane_syntax.mli b/ocaml/parsing/jane_syntax.mli index e3686805948..193b6d688ec 100644 --- a/ocaml/parsing/jane_syntax.mli +++ b/ocaml/parsing/jane_syntax.mli @@ -129,6 +129,7 @@ module Jkind : sig | Mod of t * Parsetree.modes | With of t * Parsetree.core_type | Kind_of of Parsetree.core_type + | Product of t list type annotation = t Location.loc end diff --git a/ocaml/parsing/lexer.mll b/ocaml/parsing/lexer.mll index 7fc4cd91574..7d7a6106d05 100644 --- a/ocaml/parsing/lexer.mll +++ b/ocaml/parsing/lexer.mll @@ -705,6 +705,7 @@ rule token = parse | "\'" { QUOTE } | "(" { LPAREN } | ")" { RPAREN } + | "#(" { HASHLPAREN } | "*" { STAR } | "," { COMMA } | "->" { MINUSGREATER } diff --git a/ocaml/parsing/parser.mly b/ocaml/parsing/parser.mly index 42597e939d0..9fbd5932220 100644 --- a/ocaml/parsing/parser.mly +++ b/ocaml/parsing/parser.mly @@ -923,6 +923,7 @@ let unboxed_type sloc lident tys = %token GREATER ">" %token GREATERRBRACE ">}" %token GREATERRBRACKET ">]" +%token HASHLPAREN "#(" %token IF "if" %token IN "in" %token INCLUDE "include" @@ -1067,6 +1068,7 @@ The precedences must be listed from low to high. %nonassoc FUNCTOR /* include functor M */ %right MINUSGREATER /* function_type (t -> t -> t) */ %right OR BARBAR /* expr (e || e || e) */ +%nonassoc below_AMPERSAND %right AMPERSAND AMPERAMPER /* expr (e && e && e) */ %nonassoc below_EQUAL %left INFIXOP0 EQUAL LESS GREATER /* expr (e OP e OP e) */ @@ -1089,7 +1091,7 @@ The precedences must be listed from low to high. %nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT HASH_FLOAT INT HASH_INT OBJECT LBRACE LBRACELESS LBRACKET LBRACKETBAR LBRACKETCOLON LIDENT LPAREN NEW PREFIXOP STRING TRUE UIDENT - LBRACKETPERCENT QUOTED_STRING_EXPR STACK + LBRACKETPERCENT QUOTED_STRING_EXPR STACK HASHLPAREN /* Entry points */ @@ -3043,6 +3045,8 @@ comprehension_clause: | mod_longident DOT LPAREN MODULE ext_attributes module_expr COLON error { unclosed "(" $loc($3) ")" $loc($8) } + | HASHLPAREN labeled_tuple RPAREN + { Pexp_unboxed_tuple $2 } ; labeled_simple_expr: simple_expr %prec below_HASH @@ -3664,6 +3668,9 @@ simple_delimited_pattern: (fun elts -> Ppat_array elts) $1 } + | HASHLPAREN reversed_labeled_tuple_pattern(pattern) RPAREN + { let (closed, fields) = $2 in + Ppat_unboxed_tuple (List.rev fields, closed) } ) { $1 } | array_patterns(LBRACKETCOLON, COLONRBRACKET) { Generic_array.Pattern.to_ast @@ -3889,8 +3896,22 @@ jkind: | UNDERSCORE { Jane_syntax.Jkind.Default } + | reverse_product_jkind %prec below_AMPERSAND { + Jane_syntax.Jkind.Product (List.rev $1) + } + | LPAREN jkind RPAREN { + $2 + } ; +reverse_product_jkind : + | jkind1 = jkind AMPERSAND jkind2 = jkind %prec below_EQUAL + { [jkind2; jkind1] } + | jkinds = reverse_product_jkind + AMPERSAND + jkind = jkind %prec below_EQUAL + { jkind :: jkinds } + jkind_annotation: (* : jkind_annotation *) mkrhs(jkind) { $1 } ; @@ -4468,6 +4489,22 @@ tuple_type: ltys = separated_nonempty_llist(STAR, labeled_tuple_typ_element) { ty, ltys } +(* In the case of an unboxed tuple, we don't need the nonsense above because + the [#( ... )] disambiguates. However, we still must write out + the first element explicitly because [labeled_tuple_typ_element] is + restricted to tail position by its %prec annotation. *) +%inline unboxed_tuple_type_body: + | ty1 = atomic_type + STAR + ltys = separated_nonempty_llist(STAR, labeled_tuple_typ_element) + { (None, ty1) :: ltys } + | label = LIDENT + COLON + ty1 = atomic_type + STAR + ltys = separated_nonempty_llist(STAR, labeled_tuple_typ_element) + { (Some label, ty1) :: ltys } + %inline labeled_tuple_typ_element : | atomic_type %prec STAR { None, $1 } @@ -4521,6 +4558,8 @@ atomic_type: { Ptyp_variant($3, Closed, Some []) } | LBRACKETLESS BAR? row_field_list GREATER name_tag_list RBRACKET { Ptyp_variant($3, Closed, Some $5) } + | HASHLPAREN unboxed_tuple_type_body RPAREN + { Ptyp_unboxed_tuple $2 } | extension { Ptyp_extension $1 } ) diff --git a/ocaml/parsing/parsetree.mli b/ocaml/parsing/parsetree.mli index 405538e7825..144a86344b6 100644 --- a/ocaml/parsing/parsetree.mli +++ b/ocaml/parsing/parsetree.mli @@ -108,6 +108,13 @@ and core_type_desc = (** [Ptyp_tuple([T1 ; ... ; Tn])] represents a product type [T1 * ... * Tn]. + Invariant: [n >= 2]. + *) + | Ptyp_unboxed_tuple of (string option * core_type) list + (** Unboxed tuple types: [Ptyp_unboxed_tuple([(Some l1,P1);...;(Some l2,Pn)]] + represents a product type [#(l1:T1 * ... * l2:Tn)], and the labels + are optional. + Invariant: [n >= 2]. *) | Ptyp_constr of Longident.t loc * core_type list @@ -253,6 +260,15 @@ and pattern_desc = Invariant: [n >= 2] *) + | Ppat_unboxed_tuple of (string option * pattern) list * Asttypes.closed_flag + (** Unboxed tuple patterns: [#(l1:P1, ..., ln:Pn)] is [([(Some + l1,P1);...;(Some l2,Pn)], Closed)], and the labels are optional. An + [Open] pattern ends in [..]. + + Invariant: + - If Closed, [n >= 2] + - If Open, [n >= 1] + *) | Ppat_construct of Longident.t loc * (string loc list * pattern) option (** [Ppat_construct(C, args)] represents: - [C] when [args] is [None], @@ -362,6 +378,13 @@ and expression_desc = Invariant: [n >= 2] *) + | Pexp_unboxed_tuple of (string option * expression) list + (** Unboxed tuple expressions: [Pexp_unboxed_tuple([(Some l1,P1);...;(Some + l2,Pn)])] represents [#(l1:E1, ..., ln:En)], and the labels are + optional. + + Invariant: [n >= 2] + *) | Pexp_construct of Longident.t loc * expression option (** [Pexp_construct(C, exp)] represents: - [C] when [exp] is [None], @@ -1159,6 +1182,7 @@ and jkind_annotation = | Mod of jkind_annotation * modes | With of jkind_annotation * core_type | Kind_of of core_type + | Product of jkind_annotation list (** {1 Toplevel} *) diff --git a/ocaml/parsing/pprintast.ml b/ocaml/parsing/pprintast.ml index 90be63160d2..30eaba57436 100644 --- a/ocaml/parsing/pprintast.ml +++ b/ocaml/parsing/pprintast.ml @@ -406,7 +406,7 @@ and type_with_label ctxt f (label, c, mode) = | Labelled s -> pp f "%s:%a" s (maybe_legacy_modes_type_at_modes core_type1 ctxt) (c, mode) | Optional s -> pp f "?%s:%a" s (maybe_legacy_modes_type_at_modes core_type1 ctxt) (c, mode) -and jkind ctxt f k = match (k : Jane_syntax.Jkind.t) with +and jkind ?(nested = false) ctxt f k = match (k : Jane_syntax.Jkind.t) with | Default -> pp f "_" | Abbreviation s -> pp f "%s" (s : Jane_syntax.Jkind.Const.t :> _ loc).txt @@ -415,12 +415,16 @@ and jkind ctxt f k = match (k : Jane_syntax.Jkind.t) with | [] -> Misc.fatal_error "malformed jkind annotation" | _ :: _ -> pp f "%a mod %a" - (jkind ctxt) t + (jkind ~nested:true ctxt) t (pp_print_list ~pp_sep:pp_print_space mode) modes end | With (t, ty) -> pp f "%a with %a" (jkind ctxt) t (core_type ctxt) ty | Kind_of ty -> pp f "kind_of_ %a" (core_type ctxt) ty + | Product ts -> + if nested then pp f "("; + pp f "%a" (list (jkind ~nested:true ctxt) ~sep:"@;&@;") ts; + if nested then pp f ")" and jkind_annotation ctxt f annot = jkind ctxt f annot.txt @@ -471,6 +475,8 @@ and core_type1 ctxt f x = | Ptyp_any -> pp f "_"; | Ptyp_var s -> tyvar f s; | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Ptyp_unboxed_tuple l -> + core_type1_labeled_tuple ctxt f ~unboxed:true l | Ptyp_constr (li, l) -> pp f (* "%a%a@;" *) "%a%a" (fun f l -> match l with @@ -576,7 +582,7 @@ and core_type1_jane_syntax ctxt attrs f (x : Jane_syntax.Core_type.t) = match x with | Jtyp_layout (Ltyp_var { name; jkind }) -> pp f "(%a@;:@;%a)" tyvar_option name (jkind_annotation ctxt) jkind - | Jtyp_tuple x -> core_type1_labeled_tuple ctxt attrs f x + | Jtyp_tuple x -> core_type1_labeled_tuple ctxt f ~unboxed:false x | Jtyp_layout (Ltyp_alias _ | Ltyp_poly _) -> paren true (core_type_jane_syntax ctxt attrs) f x @@ -584,10 +590,11 @@ and tyvar_option f = function | None -> pp f "_" | Some name -> tyvar f name -and core_type1_labeled_tuple ctxt _attrs f +and core_type1_labeled_tuple ctxt f ~unboxed : Jane_syntax.Labeled_tuples.core_type -> _ = fun tl -> - pp f "(%a)" (list (labeled_core_type1 ctxt) ~sep:"@;*@;") tl + pp f "%s(%a)" (if unboxed then "#" else "") + (list (labeled_core_type1 ctxt) ~sep:"@;*@;") tl and labeled_core_type1 ctxt f (label, ty) = begin match label with @@ -713,6 +720,8 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = end | Ppat_tuple l -> pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) + | Ppat_unboxed_tuple (l, closed) -> + labeled_tuple_pattern ctxt f ~unboxed:true l closed | Ppat_constant (c) -> pp f "%a" constant c | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 | Ppat_variant (l,None) -> pp f "`%s" l @@ -762,13 +771,17 @@ and pattern_jane_syntax ctxt attrs f (pat : Jane_syntax.Pattern.t) = pp f "@[<2>[:%a:]@]" (list (pattern1 ctxt) ~sep:";") l | Jpat_layout (Lpat_constant c) -> unboxed_constant ctxt f c | Jpat_tuple (l, closed) -> - let closed_flag ppf = function - | Closed -> () - | Open -> pp ppf ",@;.." - in - pp f "@[<1>(%a%a)@]" - (list ~sep:",@;" (labeled_pattern1 ctxt)) l - closed_flag closed + labeled_tuple_pattern ctxt f ~unboxed:false l closed + +and labeled_tuple_pattern ctxt f ~unboxed l closed = + let closed_flag ppf = function + | Closed -> () + | Open -> pp ppf ",@;.." + in + pp f "@[<1>%s(%a%a)@]" + (if unboxed then "#" else "") + (list ~sep:",@;" (labeled_pattern1 ctxt)) l + closed_flag closed and label_exp ctxt f (l,opt,p) = match l with @@ -1111,6 +1124,8 @@ and simple_expr ctxt f x = pp f "(module@;%a)" (module_expr ctxt) me | Pexp_tuple l -> pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l + | Pexp_unboxed_tuple l -> + labeled_tuple_expr ctxt f ~unboxed:true l | Pexp_constraint (e, ct, m) -> begin match ct with | None -> @@ -2159,7 +2174,7 @@ and jane_syntax_expr ctxt attrs f (jexp : Jane_syntax.Expression.t) ~parens = | Jexp_comprehension x -> comprehension_expr ctxt f x | Jexp_immutable_array x -> immutable_array_expr ctxt f x | Jexp_layout x -> layout_expr ctxt f x ~parens - | Jexp_tuple ltexp -> labeled_tuple_expr ctxt f ltexp + | Jexp_tuple ltexp -> labeled_tuple_expr ctxt f ~unboxed:false ltexp and comprehension_expr ctxt f (cexp : Jane_syntax.Comprehensions.expression) = let punct, comp = match cexp with @@ -2279,8 +2294,10 @@ and function_params_then_body ctxt f params constraint_ body ~delimiter = delimiter (function_body (under_functionrhs ctxt)) body -and labeled_tuple_expr ctxt f (x : Jane_syntax.Labeled_tuples.expression) = - pp f "@[(%a)@]" (list (tuple_component ctxt) ~sep:",@;") x +and labeled_tuple_expr ctxt f ~unboxed + (x : Jane_syntax.Labeled_tuples.expression) = + pp f "@[%s(%a)@]" (if unboxed then "#" else "") + (list (tuple_component ctxt) ~sep:",@;") x (******************************************************************************) (* All exported functions must be defined or redefined below here and wrapped in diff --git a/ocaml/parsing/printast.ml b/ocaml/parsing/printast.ml index 3dcd04fe89e..f5b25f711c3 100644 --- a/ocaml/parsing/printast.ml +++ b/ocaml/parsing/printast.ml @@ -153,6 +153,10 @@ let include_kind i ppf = function | Structure -> line i ppf "Structure\n" | Functor -> line i ppf "Functor\n" +let labeled_tuple_element f i ppf (l, ct) = + option i string ppf l; + f i ppf ct + let rec core_type i ppf x = line i ppf "core_type %a\n" fmt_location x.ptyp_loc; attributes i ppf x.ptyp_attributes; @@ -170,6 +174,9 @@ let rec core_type i ppf x = | Ptyp_tuple l -> line i ppf "Ptyp_tuple\n"; list i core_type ppf l; + | Ptyp_unboxed_tuple l -> + line i ppf "Ptyp_unboxed_tuple\n"; + list i (labeled_tuple_element core_type) ppf l | Ptyp_constr (li, l) -> line i ppf "Ptyp_constr %a\n" fmt_longident_loc li; list i core_type ppf l; @@ -226,6 +233,9 @@ and pattern i ppf x = | Ppat_tuple (l) -> line i ppf "Ppat_tuple\n"; list i pattern ppf l; + | Ppat_unboxed_tuple (l, c) -> + line i ppf "Ppat_unboxed_tuple %a\n" fmt_closed_flag c; + list i (labeled_tuple_element pattern) ppf l | Ppat_construct (li, po) -> line i ppf "Ppat_construct %a\n" fmt_longident_loc li; option i @@ -300,6 +310,9 @@ and expression i ppf x = | Pexp_tuple (l) -> line i ppf "Pexp_tuple\n"; list i expression ppf l; + | Pexp_unboxed_tuple (l) -> + line i ppf "Pexp_unboxed_tuple\n"; + list i (labeled_tuple_element expression) ppf l; | Pexp_construct (li, eo) -> line i ppf "Pexp_construct %a\n" fmt_longident_loc li; option i expression ppf eo; @@ -422,6 +435,9 @@ and jkind_annotation i ppf (jkind : jkind_annotation) = | Kind_of type_ -> line i ppf "Kind_of\n"; core_type (i+1) ppf type_ + | Product jkinds -> + line i ppf "Product\n"; + list i jkind_annotation ppf jkinds and function_param i ppf { pparam_desc = desc; pparam_loc = loc } = match desc with diff --git a/ocaml/testsuite/tests/language-extensions/pprintast_unconditional.ml b/ocaml/testsuite/tests/language-extensions/pprintast_unconditional.ml index b27e8579fa2..91b531b36b9 100644 --- a/ocaml/testsuite/tests/language-extensions/pprintast_unconditional.ml +++ b/ocaml/testsuite/tests/language-extensions/pprintast_unconditional.ml @@ -48,6 +48,10 @@ module Example = struct "let f (a @ local) ~(b @ local) ?(c @ local) \ ?(d @ local = 1) ~e:(e @ local) ?f:(f @ local = 2) \ () = () in f" + let utuple_exp = parse expression + "let #(x,y) : #(int * int) = #(1,2) in \ + let #(a,#(b,c)) : ('a : value & (value & value)) = #(3,#(4,5)) in + x + y + a + b + c" let modal_kind_struct = parse module_expr "struct \ @@ -195,6 +199,7 @@ end = struct let local_exp = test "local_exp" expression Example.local_exp let stack_exp = test "stack_exp" expression Example.stack_exp let fun_with_modes_on_arg = test "fun_with_modes_on_arg" expression Example.fun_with_modes_on_arg + let utuple_exp = test "utuple_exp" expression Example.utuple_exp let longident = test "longident" longident Example.longident let expression = test "expression" expression Example.expression diff --git a/ocaml/testsuite/tests/language-extensions/pprintast_unconditional.reference b/ocaml/testsuite/tests/language-extensions/pprintast_unconditional.reference index 946e74dfc76..c739f18523e 100644 --- a/ocaml/testsuite/tests/language-extensions/pprintast_unconditional.reference +++ b/ocaml/testsuite/tests/language-extensions/pprintast_unconditional.reference @@ -39,6 +39,11 @@ fun_with_modes_on_arg: ?f:(local_ f= 2) () = () in f +utuple_exp: + let #(x, y) : #(int * int) = #(1, 2) in + let #(a, #(b, c)) : ('a : value & (value & value)) = #(3, #(4, 5)) in + (((x + y) + a) + b) + c + longident: No.Longidents.Require.extensions expression: [x for x = 1 to 10] @@ -162,6 +167,11 @@ fun_with_modes_on_arg: ?f:(local_ f= 2) () = () in f +utuple_exp: + let #(x, y) : #(int * int) = #(1, 2) in + let #(a, #(b, c)) : ('a : value & (value & value)) = #(3, #(4, 5)) in + (((x + y) + a) + b) + c + longident: No.Longidents.Require.extensions expression: [x for x = 1 to 10] diff --git a/ocaml/testsuite/tests/typing-layouts-err-msg/concrete.ml b/ocaml/testsuite/tests/typing-layouts-err-msg/concrete.ml index d59eb8346c1..49d7fc879c5 100644 --- a/ocaml/testsuite/tests/typing-layouts-err-msg/concrete.ml +++ b/ocaml/testsuite/tests/typing-layouts-err-msg/concrete.ml @@ -19,7 +19,7 @@ Line 5, characters 15-37: 5 | let () = match (assert false : t_any) with _ -> () ^^^^^^^^^^^^^^^^^^^^^^ Error: This expression has type t_any but an expression was expected of type - ('a : '_representable_layout_1) + ('a : '_representable_layout_2) The layout of t_any is any because of the definition of t_any at line 1, characters 0-16. But the layout of t_any must be representable @@ -63,7 +63,7 @@ Line 2, characters 9-14: 2 | and t2 = t_any t ^^^^^ Error: This type t_any should be an instance of type - ('a : '_representable_layout_2) + ('a : '_representable_layout_5) The layout of t_any is any because of the definition of t_any at line 1, characters 0-16. But the layout of t_any must be representable @@ -85,7 +85,7 @@ Line 1, characters 4-5: ^ Error: This pattern matches values of type t_any but a pattern was expected which matches values of type - ('a : '_representable_layout_3) + ('a : '_representable_layout_7) The layout of t_any is any because of the definition of t_any at line 1, characters 0-16. But the layout of t_any must be representable @@ -101,7 +101,7 @@ Line 1, characters 6-16: ^^^^^^^^^^ Error: This pattern matches values of type t_any but a pattern was expected which matches values of type - ('a : '_representable_layout_4) + ('a : '_representable_layout_9) The layout of t_any is any because of the definition of t_any at line 1, characters 0-16. But the layout of t_any must be representable @@ -116,7 +116,7 @@ Line 1, characters 18-30: 1 | let f (): t_any = assert false ^^^^^^^^^^^^ Error: This expression has type t_any but an expression was expected of type - ('a : '_representable_layout_5) + ('a : '_representable_layout_13) The layout of t_any is any because of the definition of t_any at line 1, characters 0-16. But the layout of t_any must be representable @@ -170,7 +170,7 @@ Line 1, characters 9-21: 1 | let _ = (assert false : t_any); () ^^^^^^^^^^^^ Error: This expression has type t_any but an expression was expected of type - ('a : '_representable_layout_6) + ('a : '_representable_layout_21) because it is in the left-hand side of a sequence The layout of t_any is any because of the definition of t_any at line 1, characters 0-16. diff --git a/ocaml/testsuite/tests/typing-layouts-or-null/basics.ml b/ocaml/testsuite/tests/typing-layouts-or-null/basics.ml index f9da01df223..a3b79d08131 100644 --- a/ocaml/testsuite/tests/typing-layouts-or-null/basics.ml +++ b/ocaml/testsuite/tests/typing-layouts-or-null/basics.ml @@ -26,7 +26,7 @@ Line 1, characters 6-26: ^^^^^^^^^^^^^^^^^^^^ Error: This pattern matches values of type t_any_non_null but a pattern was expected which matches values of type - ('a : '_representable_layout_1) + ('a : '_representable_layout_2) The layout of t_any_non_null is any because of the definition of t_any_non_null at line 2, characters 0-34. But the layout of t_any_non_null must be representable @@ -79,7 +79,7 @@ Line 2, characters 13-19: 2 | let g () = X.g () ^^^^^^ Error: This expression has type t_any_non_null - but an expression was expected of type ('a : '_representable_layout_2) + but an expression was expected of type ('a : '_representable_layout_7) The layout of t_any_non_null is any because of the definition of t_any_non_null at line 2, characters 0-34. But the layout of t_any_non_null must be representable diff --git a/ocaml/testsuite/tests/typing-layouts-products/basics.ml b/ocaml/testsuite/tests/typing-layouts-products/basics.ml new file mode 100644 index 00000000000..c45bdaf6d23 --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-products/basics.ml @@ -0,0 +1,950 @@ +(* TEST + flambda2; + include stdlib_upstream_compatible; + flags = "-extension layouts_beta"; + { + expect; + } +*) + +open Stdlib_upstream_compatible + +(**********************************************************) +(* Test 1: Basic unboxed product layouts and tuple types. *) + +type t1 : float64 & value +type t2 = #(string * float# * int) +[%%expect{| +type t1 : float64 & value +type t2 = #(string * float# * int) +|}] + +(* You can put unboxed and normal products inside unboxed products *) +type t3 : value & (bits64 & (value & float32)) +type t4 = #(string * #(int * (bool * int) * char option)) +[%%expect{| +type t3 : value & (bits64 & (value & float32)) +type t4 = #(string * #(int * (bool * int) * char option)) +|}] + +(* But you can't put unboxed products into normal tuples (yet) *) +type t_nope = string * #(string * bool) +[%%expect{| +Line 1, characters 23-39: +1 | type t_nope = string * #(string * bool) + ^^^^^^^^^^^^^^^^ +Error: Tuple element types must have layout value. + The layout of #(string * bool) is value & value + because it is an unboxed tuple. + But the layout of #(string * bool) must be a sublayout of value + because it's the type of a tuple element. +|}] + +(********************************************) +(* Test 2: Simple kind annotations on types *) + +type t1 : float64 & value = #(float# * bool) +type t2 : value & (float64 & value) = #(string option * t1) +[%%expect{| +type t1 = #(float# * bool) +type t2 = #(string option * t1) +|}] + +type t2_wrong : value & float64 & value = #(string option * t1) +[%%expect{| +Line 1, characters 0-63: +1 | type t2_wrong : value & float64 & value = #(string option * t1) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The layout of type #(string option * t1) is value & (float64 & value) + because it is an unboxed tuple. + But the layout of type #(string option * t1) must be a sublayout of + value & float64 & value + because of the definition of t2_wrong at line 1, characters 0-63. +|}] + +type ('a : value & bits64) t3 = 'a +type t4 = #(int * int64#) t3 +type t5 = t4 t3 +[%%expect{| +type ('a : value & bits64) t3 = 'a +type t4 = #(int * int64#) t3 +type t5 = t4 t3 +|}] + +type t4_wrong = #(int * int) t3 +[%%expect{| +Line 1, characters 16-28: +1 | type t4_wrong = #(int * int) t3 + ^^^^^^^^^^^^ +Error: This type #(int * int) should be an instance of type + ('a : value & bits64) + The layout of #(int * int) is value & value + because it is an unboxed tuple. + But the layout of #(int * int) must be a sublayout of value & bits64 + because of the definition of t3 at line 1, characters 0-34. +|}] +(* CR layouts v7.1: The above error should identify the component of the product + that is problematic. *) + +(* some mutually recusive types *) +type ('a : value & bits64) t6 = 'a t7 +and 'a t7 = { x : 'a t6 } +[%%expect{| +type ('a : value & bits64) t6 = 'a t7 +and ('a : value & bits64) t7 = { x : 'a t6; } +|}] + +type t9 = #(int * int64#) t7 +type t10 = bool t6 +[%%expect{| +type t9 = #(int * int64#) t7 +Line 2, characters 11-15: +2 | type t10 = bool t6 + ^^^^ +Error: This type bool should be an instance of type ('a : value & bits64) + The layout of bool is value + because it's an enumeration variant type (all constructors are constant). + But the layout of bool must be a sublayout of value & bits64 + because of the definition of t6 at line 1, characters 0-37. +|}] + +type ('a : value & bits64) t6_wrong = 'a t7_wrong +and 'a t7_wrong = { x : #(int * int64) t6_wrong } +[%%expect{| +Line 2, characters 24-38: +2 | and 'a t7_wrong = { x : #(int * int64) t6_wrong } + ^^^^^^^^^^^^^^ +Error: This type #(int * int64) should be an instance of type + ('a : value & bits64) + The layout of #(int * int64) is value & value + because it is an unboxed tuple. + But the layout of #(int * int64) must be a sublayout of value & bits64 + because of the annotation on 'a in the declaration of the type + t6_wrong. +|}] +(* CR layouts v7.1: The above error should identify the component of the product + that is problematic. *) + +(* Just like t6/t7, but with the annotation on the other (the order doesn't + matter) *) +type 'a t11 = 'a t12 +and ('a : value & bits64) t12 = { x : 'a t11 } +[%%expect{| +type ('a : value & bits64) t11 = 'a t12 +and ('a : value & bits64) t12 = { x : 'a t11; } +|}] + +(* You can make a universal variable have a product layout, but you have to ask + for it *) +type ('a : float64 & value) t = 'a + +let f_uvar_good : ('a : float64 & value) . 'a -> 'a t = fun x -> x +let f_uvar_ok : 'a -> 'a t = fun x -> x + +let f_uvar_bad : 'a . 'a -> 'a t = fun x -> x +[%%expect{| +type ('a : float64 & value) t = 'a +val f_uvar_good : ('a : float64 & value). 'a -> 'a t = +val f_uvar_ok : ('a : float64 & value). 'a -> 'a t = +Line 6, characters 28-30: +6 | let f_uvar_bad : 'a . 'a -> 'a t = fun x -> x + ^^ +Error: This type ('a : value) should be an instance of type + ('b : float64 & value) + The layout of 'a is value + because it is or unifies with an unannotated universal variable. + But the layout of 'a must overlap with float64 & value + because of the definition of t at line 1, characters 0-34. +|}] + +(*********************************************************************) +(* Test 3: Unboxed products are allowed in function args and returns *) + +type t1 = #(int * bool) -> #(int * float# * #(int64# * string option)) +type t2 : value & float64 +type t3 : value & (float64 & immediate) & float64 +type t4 = t2 -> (t3 -> t3) -> t2 +[%%expect{| +type t1 = #(int * bool) -> #(int * float# * #(int64# * string option)) +type t2 : value & float64 +type t3 : value & (float64 & immediate) & float64 +type t4 = t2 -> (t3 -> t3) -> t2 +|}] + +let f_make_an_unboxed_tuple (x : string) (y : float#) = #(y, x) + +let f_pull_apart_an_unboxed_tuple (x : #(string * #(float# * float#))) = + match x with + | #(s, #(f1, f2)) -> + if s = "mul" then + Float_u.mul f1 f2 + else + Float_u.add f1 f2 +[%%expect{| +val f_make_an_unboxed_tuple : string -> float# -> #(float# * string) = +val f_pull_apart_an_unboxed_tuple : + #(string * #(float# * float#)) -> Stdlib_upstream_compatible.Float_u.t = + +|}] + +let f_mix_up_an_unboxed_tuple x = + let #(a, b, #(c, #(d, e)), f) = x in + #(b, #(c, (f, e)), a, d) +[%%expect{| +val f_mix_up_an_unboxed_tuple : + #('a * 'b * #('c * #('d * 'e)) * 'f) -> #('b * #('c * ('f * 'e)) * 'a * 'd) = + +|}] + +let f_take_a_few_unboxed_tuples x1 x2 x3 x4 x5 = + let #(a, b) = x1 in + let #(d, e) = x3 in + let #(g, h) = x5 in + #(h, g, x4, e, d, x2, b, a) +[%%expect{| +val f_take_a_few_unboxed_tuples : + #('a * 'b) -> + 'c -> + #('d * 'e) -> 'f -> #('g * 'h) -> #('h * 'g * 'f * 'e * 'd * 'c * 'b * 'a) = + +|}] + +(***************************************************) +(* Test 4: Unboxed products don't go in structures *) + +type poly_var_type = [ `Foo of #(int * bool) ] +[%%expect{| +Line 1, characters 31-44: +1 | type poly_var_type = [ `Foo of #(int * bool) ] + ^^^^^^^^^^^^^ +Error: Polymorphic variant constructor argument types must have layout value. + The layout of #(int * bool) is value & value + because it is an unboxed tuple. + But the layout of #(int * bool) must be a sublayout of value + because it's the type of the field of a polymorphic variant. +|}] + +let poly_var_term = `Foo #(1,2) +[%%expect{| +Line 1, characters 25-31: +1 | let poly_var_term = `Foo #(1,2) + ^^^^^^ +Error: This expression has type #('a * 'b) + but an expression was expected of type ('c : value) + The layout of #('a * 'b) is '_representable_layout_158 & '_representable_layout_159 + because it is an unboxed tuple. + But the layout of #('a * 'b) must be a sublayout of value + because it's the type of the field of a polymorphic variant. +|}] + +type tuple_type = (int * #(bool * float#)) +[%%expect{| +Line 1, characters 25-41: +1 | type tuple_type = (int * #(bool * float#)) + ^^^^^^^^^^^^^^^^ +Error: Tuple element types must have layout value. + The layout of #(bool * float#) is value & float64 + because it is an unboxed tuple. + But the layout of #(bool * float#) must be a sublayout of value + because it's the type of a tuple element. +|}] + +let tuple_term = ("hi", #(1, 2)) +[%%expect{| +Line 1, characters 24-31: +1 | let tuple_term = ("hi", #(1, 2)) + ^^^^^^^ +Error: This expression has type #('a * 'b) + but an expression was expected of type ('c : value) + The layout of #('a * 'b) is '_representable_layout_165 & '_representable_layout_166 + because it is an unboxed tuple. + But the layout of #('a * 'b) must be a sublayout of value + because it's the type of a tuple element. +|}] + +type record = { x : #(int * bool) } +[%%expect{| +Line 1, characters 0-35: +1 | type record = { x : #(int * bool) } + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type #(int * bool) has layout value & value. + Records may not yet contain types of this layout. +|}] + +type inlined_record = A of { x : #(int * bool) } +[%%expect{| +Line 1, characters 22-48: +1 | type inlined_record = A of { x : #(int * bool) } + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Type #(int * bool) has layout value & value. + Inlined records may not yet contain types of this layout. +|}] + +type variant = A of #(int * bool) +[%%expect{| +Line 1, characters 15-33: +1 | type variant = A of #(int * bool) + ^^^^^^^^^^^^^^^^^^ +Error: Type #(int * bool) has layout value & value. + Variants may not yet contain types of this layout. +|}] + +module type S = sig + val x : #(int * bool) +end +[%%expect{| +Line 2, characters 10-23: +2 | val x : #(int * bool) + ^^^^^^^^^^^^^ +Error: This type signature for x is not a value type. + The layout of type #(int * bool) is value & value + because it is an unboxed tuple. + But the layout of type #(int * bool) must be a sublayout of value + because it's the type of something stored in a module structure. +|}] + +module M = struct + let x = #(1, 2) +end +[%%expect{| +Line 2, characters 6-7: +2 | let x = #(1, 2) + ^ +Error: Types of top-level module bindings must have layout value, but + the type of x has layout value & value. +|}] + +type object_type = < x : #(int * bool) > +[%%expect{| +Line 1, characters 21-38: +1 | type object_type = < x : #(int * bool) > + ^^^^^^^^^^^^^^^^^ +Error: Object field types must have layout value. + The layout of #(int * bool) is value & value + because it is an unboxed tuple. + But the layout of #(int * bool) must be a sublayout of value + because it's the type of an object field. +|}] + +let object_term = object val x = #(1, 2) end +[%%expect{| +Line 1, characters 29-30: +1 | let object_term = object val x = #(1, 2) end + ^ +Error: Variables bound in a class must have layout value. + The layout of x is value & value + because it is an unboxed tuple. + But the layout of x must be a sublayout of value + because it's the type of a class field. +|}] + +class class_ = + object + method x = #(1,2) + end +[%%expect{| +Line 3, characters 15-21: +3 | method x = #(1,2) + ^^^^^^ +Error: This expression has type #('a * 'b) + but an expression was expected of type ('c : value) + The layout of #('a * 'b) is '_representable_layout_194 & '_representable_layout_195 + because it is an unboxed tuple. + But the layout of #('a * 'b) must be a sublayout of value + because it's the type of an object field. +|}] + +let capture_in_object utup = object + val f = fun () -> + let #(x,y) = utup in + x + y +end;; +[%%expect{| +Line 3, characters 17-21: +3 | let #(x,y) = utup in + ^^^^ +Error: This expression has type ('a : value) + but an expression was expected of type #('b * 'c) + The layout of #('a * 'b) is '_representable_layout_206 & '_representable_layout_207 + because it is an unboxed tuple. + But the layout of #('a * 'b) must be a sublayout of value + because it's the type of a variable captured in an object. +|}];; +(****************************************************) +(* Test 5: Methods may take/return unboxed products *) + +class class_with_utuple_manipulating_method = + object + method f #(a, b) #(c, d) = #(a + c, b + d) + end +[%%expect{| +class class_with_utuple_manipulating_method : + object method f : #(int * int) -> #(int * int) -> #(int * int) end +|}] + +(*******************************************) +(* Test 6: Nested expansion in kind checks *) + +(* This test shows that the [check_coherence] check in Typedecl can look deeply + into a product kind. That check is reached in this case because the + algorithm in typedecl assumes the annotation is correct initially, and then + it is checked in [check_coherence]. This relies on [type_jkind] doing + deep expansion, as [check_coherence] calls it and then [Jkind.sub], rather + than using [check_type_jkind]. *) +module type S_coherence_deep = sig + type t1 : any + type t2 = #(int * t1) +end + +module type S_coherence_deep' = S_coherence_deep with type t1 = float# + +module F(X : S_coherence_deep') = struct + type r : value & float64 = X.t2 +end +[%%expect{| +module type S_coherence_deep = sig type t1 : any type t2 = #(int * t1) end +module type S_coherence_deep' = + sig type t1 = float# type t2 = #(int * t1) end +module F : functor (X : S_coherence_deep') -> sig type r = X.t2 end +|}] + +module type S_coherence_deeper = sig + type t1 : any + type t2 = #(int * t1) + type t3 = #(t2 * bool * int64#) + type t4 = #(float# * t3 * int) +end + +module type S_coherence_deeper' = S_coherence_deeper with type t1 = float# + +module F(X : S_coherence_deeper') = struct + type r : float64 & ((value & float64) & value & bits64) & value = X.t4 +end +[%%expect{| +module type S_coherence_deeper = + sig + type t1 : any + type t2 = #(int * t1) + type t3 = #(t2 * bool * int64#) + type t4 = #(float# * t3 * int) + end +module type S_coherence_deeper' = + sig + type t1 = float# + type t2 = #(int * t1) + type t3 = #(t2 * bool * int64#) + type t4 = #(float# * t3 * int) + end +module F : functor (X : S_coherence_deeper') -> sig type r = X.t4 end +|}] + +(* Like the above, but hitting the nested expansion case in + [constrain_type_jkind] *) +module type S_constrain_type_jkind_deep = sig + type t1 : any + type t2 = #(int * t1) +end + +module type S_constrain_type_jkind_deep' = + S_constrain_type_jkind_deep with type t1 = float# + +type ('a : value & float64) t_constraint + +module F(X : S_constrain_type_jkind_deep') = struct + type r = X.t2 t_constraint +end +[%%expect{| +module type S_constrain_type_jkind_deep = + sig type t1 : any type t2 = #(int * t1) end +module type S_constrain_type_jkind_deep' = + sig type t1 = float# type t2 = #(int * t1) end +type ('a : value & float64) t_constraint +module F : + functor (X : S_constrain_type_jkind_deep') -> + sig type r = X.t2 t_constraint end +|}] + +module type S_constrain_type_jkind_deeper = sig + type t1 : any + type t2 = #(int * t1) + type t3 = #(t2 * bool * int64#) + type t4 = #(float# * t3 * int) +end + +module type S_constrain_type_jkind_deeper' = + S_constrain_type_jkind_deeper with type t1 = float# + +type ('a : float64 & ((value & float64) & value & bits64) & value) t_constraint + +module F(X : S_constrain_type_jkind_deeper') = struct + type r = X.t4 t_constraint +end +[%%expect{| +module type S_constrain_type_jkind_deeper = + sig + type t1 : any + type t2 = #(int * t1) + type t3 = #(t2 * bool * int64#) + type t4 = #(float# * t3 * int) + end +module type S_constrain_type_jkind_deeper' = + sig + type t1 = float# + type t2 = #(int * t1) + type t3 = #(t2 * bool * int64#) + type t4 = #(float# * t3 * int) + end +type ('a : float64 & ((value & float64) & value & bits64) & value) + t_constraint +module F : + functor (X : S_constrain_type_jkind_deeper') -> + sig type r = X.t4 t_constraint end +|}] + +(***********************************************) +(* Test 7: modal kinds for unboxed tuple types *) + +let f_external_utuple_mode_crosses_local_1 + : local_ #(int * int) -> #(int * int) = fun x -> x +[%%expect{| +val f_external_utuple_mode_crosses_local_1 : + local_ #(int * int) -> #(int * int) = +|}] + +let f_internal_utuple_does_not_mode_cross_local_1 + : local_ #(int * string) -> #(int * string) = fun x -> x +[%%expect{| +Line 2, characters 57-58: +2 | : local_ #(int * string) -> #(int * string) = fun x -> x + ^ +Error: This value escapes its region. +|}] + +let f_external_utuple_mode_crosses_local_2 + : local_ #(int * #(bool * int)) -> #(int * #(bool * int)) = fun x -> x +[%%expect{| +val f_external_utuple_mode_crosses_local_2 : + local_ #(int * #(bool * int)) -> #(int * #(bool * int)) = +|}] + +let f_internal_utuple_does_not_mode_cross_local_2 + : local_ #(int * #(bool * string)) -> #(int * #(bool * string)) = fun x -> x +[%%expect{| +Line 2, characters 77-78: +2 | : local_ #(int * #(bool * string)) -> #(int * #(bool * string)) = fun x -> x + ^ +Error: This value escapes its region. +|}] + +type t = #(int * int) +let f_external_utuple_mode_crosses_local_3 + : local_ #(int * #(t * int)) -> #(int * #(t * int)) = fun x -> x +[%%expect{| +type t = #(int * int) +val f_external_utuple_mode_crosses_local_3 : + local_ #(int * #(t * int)) -> #(int * #(t * int)) = +|}] + +type t = #(string * int) +let f_internal_utuple_does_not_mode_cross_local_3 + : local_ #(int * #(t * bool)) -> #(int * #(t * bool)) = fun x -> x +[%%expect{| +type t = #(string * int) +Line 3, characters 67-68: +3 | : local_ #(int * #(t * bool)) -> #(int * #(t * bool)) = fun x -> x + ^ +Error: This value escapes its region. +|}] + +(****************************************************) +(* Test 8: modal kinds for product kind annotations *) + +type t : float64 & float64 +let f_external_kind_annot_mode_crosses_local_1 + : local_ t -> t = fun x -> x +[%%expect{| +type t : float64 & float64 +val f_external_kind_annot_mode_crosses_local_1 : local_ t -> t = +|}] + +type t : float64 & value +let f_internal_kind_annot_does_not_mode_cross_local_1 + : local_ t -> t = fun x -> x +[%%expect{| +type t : float64 & value +Line 3, characters 29-30: +3 | : local_ t -> t = fun x -> x + ^ +Error: This value escapes its region. +|}] + +type t : immediate & (float64 & immediate) +let f_external_kind_annot_mode_crosses_local_2 + : local_ t -> t = fun x -> x +[%%expect{| +type t : immediate & (float64 & immediate) +val f_external_kind_annot_mode_crosses_local_2 : local_ t -> t = +|}] + +type t : immediate & (value & float64) +let f_internal_kind_annot_does_not_mode_cross_local_2 + : local_ t -> t = fun x -> x +[%%expect{| +type t : immediate & (value & float64) +Line 3, characters 29-30: +3 | : local_ t -> t = fun x -> x + ^ +Error: This value escapes its region. +|}] + +(*********************) +(* Test 9: externals *) + +(* CR layouts v7.1: Unboxed products should be allowed for some primitives, like + %identity *) + +type t_product : value & value + +external ext_tuple_arg : #(int * bool) -> int = "foo" +[%%expect{| +type t_product : value & value +Line 3, characters 25-38: +3 | external ext_tuple_arg : #(int * bool) -> int = "foo" + ^^^^^^^^^^^^^ +Error: Unboxed product layouts are not supported in external declarations +|}] + +external ext_tuple_arg_with_attr : (#(int * bool) [@unboxed]) -> int = "foo" +[%%expect{| +Line 1, characters 36-49: +1 | external ext_tuple_arg_with_attr : (#(int * bool) [@unboxed]) -> int = "foo" + ^^^^^^^^^^^^^ +Error: Unboxed product layouts are not supported in external declarations +|}] + +external ext_product_arg : t_product -> int = "foo" +[%%expect{| +Line 1, characters 27-36: +1 | external ext_product_arg : t_product -> int = "foo" + ^^^^^^^^^ +Error: Unboxed product layouts are not supported in external declarations +|}] + +external ext_product_arg_with_attr : (t_product [@unboxed]) -> int = "foo" +[%%expect{| +Line 1, characters 38-47: +1 | external ext_product_arg_with_attr : (t_product [@unboxed]) -> int = "foo" + ^^^^^^^^^ +Error: Unboxed product layouts are not supported in external declarations +|}] + +external ext_tuple_return : int -> #(int * bool) = "foo" +[%%expect{| +Line 1, characters 35-48: +1 | external ext_tuple_return : int -> #(int * bool) = "foo" + ^^^^^^^^^^^^^ +Error: Unboxed product layouts are not supported in external declarations +|}] + +external ext_tuple_return_with_attr : int -> (#(int * bool) [@unboxed]) = "foo" +[%%expect{| +Line 1, characters 46-59: +1 | external ext_tuple_return_with_attr : int -> (#(int * bool) [@unboxed]) = "foo" + ^^^^^^^^^^^^^ +Error: Unboxed product layouts are not supported in external declarations +|}] + +external ext_product_return : int -> t_product = "foo" +[%%expect{| +Line 1, characters 37-46: +1 | external ext_product_return : int -> t_product = "foo" + ^^^^^^^^^ +Error: Unboxed product layouts are not supported in external declarations +|}] + +external ext_product_return_with_attr : int -> (t_product [@unboxed]) = "foo" +[%%expect{| +Line 1, characters 48-57: +1 | external ext_product_return_with_attr : int -> (t_product [@unboxed]) = "foo" + ^^^^^^^^^ +Error: Unboxed product layouts are not supported in external declarations +|}] + +external[@layout_poly] id : ('a : any). 'a -> 'a = "%identity" + +let sum = + let #(x,y) = id #(1,2) in + x + y +[%%expect{| +external id : ('a : any). 'a -> 'a = "%identity" [@@layout_poly] +Line 4, characters 18-24: +4 | let #(x,y) = id #(1,2) in + ^^^^^^ +Error: Unboxed product layouts are not yet supported as arguments to + layout polymorphic externals. + The layout of this argument is value & value. +|}] + +(* CR layouts v7.1: Unboxed products should be allowed for some primitives, like + %identity *) + +(***********************************) +(* Test 9: not allowed in let recs *) + +(* An example that is allowed on tuples but not unboxed tuples *) +let[@warning "-26"] e1 = let rec x = (1, y) and y = 42 in () +let[@warning "-26"] e2 = let rec x = #(1, y) and y = 42 in () +[%%expect{| +val e1 : unit = () +Line 2, characters 37-44: +2 | let[@warning "-26"] e2 = let rec x = #(1, y) and y = 42 in () + ^^^^^^^ +Error: This expression has type #('a * 'b) + but an expression was expected of type ('c : value) + The layout of #('a * 'b) is '_representable_layout_366 & '_representable_layout_367 + because it is an unboxed tuple. + But the layout of #('a * 'b) must be a sublayout of value + because it's the type of the recursive variable x. +|}] + +(* This example motivates having a check in [type_let], because + [Value_rec_check] is not set up to reject it, but we don't support even this + limited form of unboxed let rec (yet). *) +let _ = let rec _x = #(3, 10) and _y = 42 in 42 +[%%expect{| +Line 1, characters 21-29: +1 | let _ = let rec _x = #(3, 10) and _y = 42 in 42 + ^^^^^^^^ +Error: This expression has type #('a * 'b) + but an expression was expected of type ('c : value) + The layout of #('a * 'b) is '_representable_layout_373 & '_representable_layout_374 + because it is an unboxed tuple. + But the layout of #('a * 'b) must be a sublayout of value + because it's the type of the recursive variable _x. +|}] + +(**********************************************************) +(* Test 10: not allowed in [@@unboxed] declarations (yet) *) + +type ('a : value & value) t = A of 'a [@@unboxed] +[%%expect{| +Line 1, characters 30-37: +1 | type ('a : value & value) t = A of 'a [@@unboxed] + ^^^^^^^ +Error: Type 'a has layout value & value. + Unboxed variants may not yet contain types of this layout. +|}] + +type t = A of #(int * int) [@@unboxed] +[%%expect{| +Line 1, characters 9-26: +1 | type t = A of #(int * int) [@@unboxed] + ^^^^^^^^^^^^^^^^^ +Error: Type #(int * int) has layout value & value. + Unboxed variants may not yet contain types of this layout. +|}] + +type ('a : value & value) t = A of { x : 'a } [@@unboxed] +[%%expect{| +Line 1, characters 37-43: +1 | type ('a : value & value) t = A of { x : 'a } [@@unboxed] + ^^^^^^ +Error: Type 'a has layout value & value. + Unboxed inlined records may not yet contain types of this layout. +|}] + +type t = A of { x : #(int * int) } [@@unboxed] +[%%expect{| +Line 1, characters 16-32: +1 | type t = A of { x : #(int * int) } [@@unboxed] + ^^^^^^^^^^^^^^^^ +Error: Type #(int * int) has layout value & value. + Unboxed inlined records may not yet contain types of this layout. +|}] + +(**************************************) +(* Test 11: Unboxed tuples and arrays *) + +(* You can write the type of an array of unboxed tuples, but not create + one. Soon, you can do both. *) +type ('a : value & value) t1 = 'a array +type ('a : bits64 & (value & float64)) t2 = 'a array +type t3 = #(int * bool) array +type t4 = #(string * #(float# * bool option)) array +[%%expect{| +type ('a : value & value) t1 = 'a array +type ('a : bits64 & (value & float64)) t2 = 'a array +type t3 = #(int * bool) array +type t4 = #(string * #(float# * bool option)) array +|}] + +(* CR layouts v7.1: This example demonstrates a bug in type inference that we + should fix. The issue is the way typing of tuple expressions works - we + create type variables at generic level and then constrain them by the + expected type. This will fail if it requires to refine the kind, because we + don't allow refining kinds at generic level. We need to remove the + restriction that kinds of things at generic level can't be modified, but that + is orthogonal to unboxed tuples so we leave in this sad bug for now. *) +let _ = [| #(1,2) |] +[%%expect{| +Line 1, characters 11-17: +1 | let _ = [| #(1,2) |] + ^^^^^^ +Error: This expression has type #('a * 'b) + but an expression was expected of type + ('c : '_representable_layout_397 & '_representable_layout_398) + The kind of #('a * 'b) is + '_representable_layout_397 & '_representable_layout_398 + because it is an unboxed tuple. + But the kind of #('a * 'b) must be a subkind of + '_representable_layout_397 & '_representable_layout_398 + because it's the type of an array element. +|}] + +let _ = Array.init 3 (fun _ -> #(1,2)) +[%%expect{| +Line 1, characters 31-37: +1 | let _ = Array.init 3 (fun _ -> #(1,2)) + ^^^^^^ +Error: This expression has type #('a * 'b) + but an expression was expected of type ('c : value) + The layout of #('a * 'b) is '_representable_layout_404 & '_representable_layout_405 + because it is an unboxed tuple. + But the layout of #('a * 'b) must be a sublayout of value + because of layout requirements from an imported definition. +|}] + +external make : ('a : value & value) . int -> 'a -> 'a array = "caml_make_vect" +[%%expect{| +Line 1, characters 46-48: +1 | external make : ('a : value & value) . int -> 'a -> 'a array = "caml_make_vect" + ^^ +Error: Unboxed product layouts are not supported in external declarations +|}] + +external[@layout_poly] make : ('a : any) . int -> 'a -> 'a array = + "caml_make_vect" + +let _ = make 3 #(1,2) +[%%expect{| +Lines 1-2, characters 0-18: +1 | external[@layout_poly] make : ('a : any) . int -> 'a -> 'a array = +2 | "caml_make_vect" +Error: Attribute [@layout_poly] can only be used on built-in primitives. +|}] + +external[@layout_poly] array_get : ('a : any) . 'a array -> int -> 'a = + "%array_safe_get" +let f x : #(int * int) = array_get x 3 +[%%expect{| +external array_get : ('a : any). 'a array -> int -> 'a = "%array_safe_get" + [@@layout_poly] +Line 3, characters 25-38: +3 | let f x : #(int * int) = array_get x 3 + ^^^^^^^^^^^^^ +Error: Unboxed product layouts are not yet supported as arguments to + layout polymorphic externals. + The layout of this argument is value & value. +|}] + +external[@layout_poly] array_set : ('a : any) . 'a array -> int -> 'a -> unit = + "%array_safe_set" +let f x = array_set x 3 #(1,2) +[%%expect{| +external array_set : ('a : any). 'a array -> int -> 'a -> unit + = "%array_safe_set" [@@layout_poly] +Line 3, characters 24-30: +3 | let f x = array_set x 3 #(1,2) + ^^^^^^ +Error: Unboxed product layouts are not yet supported as arguments to + layout polymorphic externals. + The layout of this argument is value & value. +|}] + + +(***********************************************************) +(* Test 12: Unboxed products are not allowed as class args *) + +class product_instance_variable x = + let sum = let #(a,b) = x in a + b in + object + method y = sum + end;; +[%%expect{| +Line 2, characters 25-26: +2 | let sum = let #(a,b) = x in a + b in + ^ +Error: This expression has type ('a : value) + but an expression was expected of type #('b * 'c) + The layout of #('a * 'b) is '_representable_layout_450 & '_representable_layout_451 + because it is an unboxed tuple. + But the layout of #('a * 'b) must be a sublayout of value + because it's the type of a term-level argument to a class constructor. +|}] + +(*****************************************) +(* Test 13: No lazy unboxed products yet *) + +let x = lazy #(1,2) + +[%%expect{| +Line 1, characters 13-19: +1 | let x = lazy #(1,2) + ^^^^^^ +Error: This expression has type #('a * 'b) + but an expression was expected of type ('c : value) + The layout of #('a * 'b) is '_representable_layout_455 & '_representable_layout_456 + because it is an unboxed tuple. + But the layout of #('a * 'b) must be a sublayout of value + because it's the type of a lazy expression. +|}] + +type t = #(int * int) lazy_t + +[%%expect{| +Line 1, characters 9-21: +1 | type t = #(int * int) lazy_t + ^^^^^^^^^^^^ +Error: This type #(int * int) should be an instance of type ('a : value) + The layout of #(int * int) is value & value + because it is an unboxed tuple. + But the layout of #(int * int) must be a sublayout of value + because the type argument of lazy_t has layout value. +|}] + +(***************************************) +(* Test 14: Coercions work covariantly *) + +type t = private int + +let f (x : #(t * t)) = + let #(a,b) = (x :> #(int * int)) in a + b +[%%expect{| +type t = private int +val f : #(t * t) -> int = +|}] + +let g (x : #(int * int)) = f (x :> #(t * t)) +[%%expect{| +Line 1, characters 29-44: +1 | let g (x : #(int * int)) = f (x :> #(t * t)) + ^^^^^^^^^^^^^^^ +Error: Type #(int * int) is not a subtype of #(t * t) + Type int is not a subtype of t +|}] + +(************************************************) +(* Test 15: Not allowed as an optional argument *) + +let f_optional_utuple ?(x = #(1,2)) () = x +[%%expect{| +Line 1, characters 28-34: +1 | let f_optional_utuple ?(x = #(1,2)) () = x + ^^^^^^ +Error: This expression has type #('a * 'b) + but an expression was expected of type ('c : value) + The layout of #('a * 'b) is '_representable_layout_485 & '_representable_layout_486 + because it is an unboxed tuple. + But the layout of #('a * 'b) must be a sublayout of value + because the type argument of option has layout value. +|}] diff --git a/ocaml/testsuite/tests/typing-layouts-products/basics_alpha.ml b/ocaml/testsuite/tests/typing-layouts-products/basics_alpha.ml new file mode 100644 index 00000000000..9b3612644d0 --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-products/basics_alpha.ml @@ -0,0 +1,96 @@ +(* TEST + flambda2; + include stdlib_upstream_compatible; + flags = "-extension layouts_alpha"; + { + expect; + } +*) +(* CR layouts v3: This test is in [layouts_alpha] just because it is about + [or_null]. Once [or_null] is appropriately mature, it can be folded into the + other test file. Note also that the test involves the nullability of [any], + which is currently different between [alpha] and [beta], so the test may need + to be adjusted. *) + +(***********************************) +(* Test 1: nullability of products *) + +(* In earlier versions we thought the nullability of a product should be the + meet of its elements. We've now realized it should be the join, at least for + now. This test shows the current behavior. *) + +(* Should be allowed *) +type t1 : any mod non_null +type t2 : value +type t3 : any mod non_null = #(t1 * t2);; +[%%expect{| +type t1 : any mod non_null +type t2 +type t3 = #(t1 * t2) +|}] + +type t1 : any mod non_null +type t2 : value +type t3 : (any & value) mod non_null = #(t1 * t2);; +[%%expect{| +type t1 : any mod non_null +type t2 +type t3 = #(t1 * t2) +|}] + +type t1 : any mod non_null +type t2 : value +type t3 : any mod non_null & value mod non_null = #(t1 * t2);; +[%%expect{| +type t1 : any mod non_null +type t2 +type t3 = #(t1 * t2) +|}] + +(* Should not be allowed. *) +type t1 : any +type t2 : any mod non_null +type t3 : any mod non_null = #(t1 * t2);; +[%%expect{| +type t1 : any +type t2 : any mod non_null +Line 3, characters 0-39: +3 | type t3 : any mod non_null = #(t1 * t2);; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The kind of type #(t1 * t2) is any & any + because it is an unboxed tuple. + But the kind of type #(t1 * t2) must be a subkind of any_non_null + because of the definition of t3 at line 3, characters 0-39. +|}] + +type t1 : any +type t2 : any mod non_null +type t3 : (any & any) mod non_null = #(t1 * t2);; +[%%expect{| +type t1 : any +type t2 : any mod non_null +Line 3, characters 0-47: +3 | type t3 : (any & any) mod non_null = #(t1 * t2);; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The kind of type #(t1 * t2) is any & any + because it is an unboxed tuple. + But the kind of type #(t1 * t2) must be a subkind of + any_non_null & any_non_null + because of the definition of t3 at line 3, characters 0-47. +|}] + +type t1 : any +type t2 : any mod non_null +type t3 : any mod non_null & any mod non_null = #(t1 * t2);; +[%%expect{| +type t1 : any +type t2 : any mod non_null +Line 3, characters 0-58: +3 | type t3 : any mod non_null & any mod non_null = #(t1 * t2);; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The kind of type #(t1 * t2) is any & any + because it is an unboxed tuple. + But the kind of type #(t1 * t2) must be a subkind of + any_non_null & any_non_null + because of the definition of t3 at line 3, characters 0-58. +|}] diff --git a/ocaml/testsuite/tests/typing-layouts-products/maturity.ml b/ocaml/testsuite/tests/typing-layouts-products/maturity.ml new file mode 100644 index 00000000000..86d2291756e --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-products/maturity.ml @@ -0,0 +1,45 @@ +(* TEST + + expect; +*) + +(* This test just shows you need layouts beta to use the various unboxed product + syntactic form. It can be removed when we move products out of beta. *) + +type t : value & value +[%%expect{| +Line 1, characters 9-22: +1 | type t : value & value + ^^^^^^^^^^^^^ +Error: Layout value & value is more experimental than allowed by the enabled layouts extension. + You must enable -extension layouts_beta to use this feature. +|}] + +type t = #(int * bool) +[%%expect{| +Line 1, characters 9-22: +1 | type t = #(int * bool) + ^^^^^^^^^^^^^ +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used +|}] + +let _ = + let _ = #(1,2) in + () +[%%expect{| +Line 2, characters 10-16: +2 | let _ = #(1,2) in + ^^^^^^ +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used +|}] + +let f x = + let #(_,_) = x in + () +[%%expect{| +Line 2, characters 6-12: +2 | let #(_,_) = x in + ^^^^^^ +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used +|}] + diff --git a/ocaml/testsuite/tests/typing-layouts-products/parsing_nullary_term.compilers.reference b/ocaml/testsuite/tests/typing-layouts-products/parsing_nullary_term.compilers.reference new file mode 100644 index 00000000000..447a0e05d3f --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-products/parsing_nullary_term.compilers.reference @@ -0,0 +1,4 @@ +File "parsing_nullary_term.ml", line 11, characters 10-11: +11 | let x = #() + ^ +Error: Syntax error diff --git a/ocaml/testsuite/tests/typing-layouts-products/parsing_nullary_term.ml b/ocaml/testsuite/tests/typing-layouts-products/parsing_nullary_term.ml new file mode 100644 index 00000000000..a277b8afb2d --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-products/parsing_nullary_term.ml @@ -0,0 +1,11 @@ +(* TEST + flags = "-extension-universe beta"; + setup-ocamlc.byte-build-env; + ocamlc_byte_exit_status = "2"; + ocamlc.byte; + check-ocamlc.byte-output; +*) + +(* This does not parse, but might one day. *) + +let x = #() diff --git a/ocaml/testsuite/tests/typing-layouts-products/parsing_nullary_type.compilers.reference b/ocaml/testsuite/tests/typing-layouts-products/parsing_nullary_type.compilers.reference new file mode 100644 index 00000000000..11ce8a91e61 --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-products/parsing_nullary_type.compilers.reference @@ -0,0 +1,4 @@ +File "parsing_nullary_type.ml", line 11, characters 11-12: +11 | type t = #() + ^ +Error: Syntax error diff --git a/ocaml/testsuite/tests/typing-layouts-products/parsing_nullary_type.ml b/ocaml/testsuite/tests/typing-layouts-products/parsing_nullary_type.ml new file mode 100644 index 00000000000..eea0439938b --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-products/parsing_nullary_type.ml @@ -0,0 +1,11 @@ +(* TEST + flags = "-extension-universe beta"; + setup-ocamlc.byte-build-env; + ocamlc_byte_exit_status = "2"; + ocamlc.byte; + check-ocamlc.byte-output; +*) + +(* This does not parse, but might one day. *) + +type t = #() diff --git a/ocaml/testsuite/tests/typing-layouts-products/parsing_unary_term.compilers.reference b/ocaml/testsuite/tests/typing-layouts-products/parsing_unary_term.compilers.reference new file mode 100644 index 00000000000..8997eb3b4be --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-products/parsing_unary_term.compilers.reference @@ -0,0 +1,4 @@ +File "parsing_unary_term.ml", line 11, characters 12-13: +11 | let x = #(42) + ^ +Error: Syntax error diff --git a/ocaml/testsuite/tests/typing-layouts-products/parsing_unary_term.ml b/ocaml/testsuite/tests/typing-layouts-products/parsing_unary_term.ml new file mode 100644 index 00000000000..48964656d42 --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-products/parsing_unary_term.ml @@ -0,0 +1,11 @@ +(* TEST + flags = "-extension-universe beta"; + setup-ocamlc.byte-build-env; + ocamlc_byte_exit_status = "2"; + ocamlc.byte; + check-ocamlc.byte-output; +*) + +(* This does not parse, nor should it. *) + +let x = #(42) diff --git a/ocaml/testsuite/tests/typing-layouts-products/parsing_unary_type.compilers.reference b/ocaml/testsuite/tests/typing-layouts-products/parsing_unary_type.compilers.reference new file mode 100644 index 00000000000..81acebf05dd --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-products/parsing_unary_type.compilers.reference @@ -0,0 +1,4 @@ +File "parsing_unary_type.ml", line 11, characters 14-15: +11 | type t = #(int) + ^ +Error: Syntax error diff --git a/ocaml/testsuite/tests/typing-layouts-products/parsing_unary_type.ml b/ocaml/testsuite/tests/typing-layouts-products/parsing_unary_type.ml new file mode 100644 index 00000000000..a107a4dc1db --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-products/parsing_unary_type.ml @@ -0,0 +1,11 @@ +(* TEST + flags = "-extension-universe beta"; + setup-ocamlc.byte-build-env; + ocamlc_byte_exit_status = "2"; + ocamlc.byte; + check-ocamlc.byte-output; +*) + +(* This does not parse, nor should it. *) + +type t = #(int) diff --git a/ocaml/testsuite/tests/typing-layouts-products/unboxed_tuples.ml b/ocaml/testsuite/tests/typing-layouts-products/unboxed_tuples.ml new file mode 100644 index 00000000000..98b2f691095 --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-products/unboxed_tuples.ml @@ -0,0 +1,458 @@ +(* TEST + reference = "${test_source_directory}/unboxed_tuples.reference"; + include stdlib_upstream_compatible; + flambda2; + { + ocamlc_byte_exit_status = "2"; + setup-ocamlc.byte-build-env; + compiler_reference = "${test_source_directory}/unboxed_tuples_stable.compilers.reference"; + ocamlc.byte; + check-ocamlc.byte-output; + }{ + ocamlc_byte_exit_status = "2"; + setup-ocamlc.byte-build-env; + flags = "-extension-universe upstream_compatible"; + compiler_reference = "${test_source_directory}/unboxed_tuples_stable.compilers.reference"; + ocamlc.byte; + check-ocamlc.byte-output; + }{ + ocamlc_byte_exit_status = "2"; + setup-ocamlc.byte-build-env; + flags = "-extension-universe no_extensions"; + compiler_reference = "${test_source_directory}/unboxed_tuples_disabled.compilers.reference"; + ocamlc.byte; + check-ocamlc.byte-output; + } { + flags = "-extension layouts_alpha"; + native; + } { + flags = "-extension layouts_alpha -Oclassic"; + native; + } { + flags = "-extension layouts_alpha -O3"; + native; + }{ + flags = "-extension layouts_alpha"; + bytecode; + }{ + flags = "-extension layouts_beta"; + native; + }{ + flags = "-extension layouts_beta -Oclassic"; + native; + }{ + flags = "-extension layouts_beta -O3"; + native; + }{ + flags = "-extension layouts_beta"; + bytecode; + } +*) + +open Stdlib_upstream_compatible + +let print_floatu prefix x = Printf.printf "%s: %.2f\n" prefix (Float_u.to_float x) +let print_float prefix x = Printf.printf "%s: %.2f\n" prefix x +let print_int prefix x = Printf.printf "%s: %d\n" prefix x +let print_ints prefix #(x,y) = Printf.printf "%s: #(%d,%d)\n" prefix x y + +(*******************************************************) +(* Test 1: Basic functions manipulating unboxed tuples *) + +(* takes a tuple *) +let mult_float_by_int #(f, i) = Float_u.(mul f (of_int i)) + +(* returns a tuple *) +let div_mod m n = #(m/n, m mod n) + +(* take multiple nested tuples, returns a nested tuple *) +let add_some_stuff x y = + let #(a,b,#(c,d)) = x in + let #(e,#(f,#(g,h,i))) = y in + #(a+b+c, #(d+e+f, g+h+i)) + +let test1 () = + let pi = #3.14 in + print_floatu "Test 1, twice pi inlined" + ((mult_float_by_int [@inlined]) #(pi,2)); + print_floatu "Test 1, twice pi not inlined" + ((mult_float_by_int [@inlined never]) #(pi,2)); + print_ints "Test 1, 14/3 inlined" ((div_mod [@inlined hint]) 14 3); + print_ints "Test 1, 14/3 not inlined" ((div_mod [@inlined never]) 14 3); + let #(a,#(b,c)) = + (add_some_stuff [@inlined]) #(1,2,#(3,4)) #(5,#(6,#(7,8,9))) + in + Printf.printf "Test 1, #(6,#(15,24)) inlined: #(%d,#(%d,%d))\n" a b c; + let #(a,#(b,c)) = + (add_some_stuff [@inlined never]) #(1,2,#(3,4)) #(5,#(6,#(7,8,9))) + in + Printf.printf "Test 1, #(6,#(15,24)) not inlined: #(%d,#(%d,%d))\n" a b c + +let _ = test1 () + +(**********************************) +(* Test 2: higher-order functions *) + +type t = #(int * #(float# * float)) + +let[@inline never] add_t #(i1,#(f1,f1')) #(i2,#(f2,f2')) = + #(i1 + i2, #(Float_u.add f1 f2, f1' +. f2')) + +let[@inline never] sub_t #(i1,#(f1,f1')) #(i2,#(f2,f2')) = + #(i1 - i2, #(Float_u.sub f1 f2, f1' -. f2')) + +let[@inline never] twice f (x : t) = f (f x) + +let[@inline never] compose f g (x : t) = f (g x) + +let t_sum #(i,#(f1,f2)) = + ((Float.of_int i) +. (Float_u.to_float f1 +. f2)) + +let print_t_sum prefix t = Printf.printf "%s: %.2f\n" prefix (t_sum t) + +let[@inline never] twice_on_pi f = + let pi = #(1, #(#2.0, 0.14)) in + twice f pi + +let times_four = + twice (fun x -> add_t x x) + +let _ = + let pi = #(1, #(#2.0, 0.14)) in + let one = #(0, #(#1.0, 0.0)) in + let zero = #(0, #(#0.0, 0.0)) in + + print_t_sum "Test 2, add pi twice" + (twice (fun x -> add_t x pi) zero); + print_t_sum "Test 2, add pi four times" + (twice (twice (fun x -> add_t x pi)) zero); + print_t_sum "Test 2, increment pi twice" + (twice_on_pi (fun x -> add_t one x)); + print_t_sum "Test 2, increment pi four times" + (twice_on_pi (twice (fun x -> add_t one x))); + print_t_sum "Test 2, e times four" + (times_four #(1, #(#1.0, 2.72))); + print_t_sum "Test 2, pi times sixteen" + (twice_on_pi times_four); + print_t_sum "Test 2, pi times sixteen again" + (compose times_four times_four pi); + print_t_sum "Test 2, pi minus four" + (let two = twice (fun x -> add_t x one) zero in + let add_two = add_t two in + let add_two_after = compose add_two in + let minus_four = + add_two_after (twice (fun x -> add_t x #(-1,#(-#1.0, -1.0)))) + in + minus_four pi) + +(**************************************) +(* Test 3: unboxed tuples in closures *) + +(* [go]'s closure should have an unboxed tuple with an [int] (immediate), a [float#] + (float64) and a [float array] (value). *) +let[@inline never] f3 bounds steps_init () = + let[@inline never] rec go k = + let #(n,m) = bounds in + let #(steps, init) = steps_init in + if k = n + then init + else begin + let acc = go (k + 1) in + steps.(k) <- Float_u.to_float acc; + Float_u.add m acc + end + in + go 0 + +(* many args - odd args are floats, even args are unboxed tuples *) +let[@inline_never] f3_manyargs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 steps () = + let #(start_k, end_k) = x0 in + let[@inline never] rec go k = + if k = end_k + then 0.0 + else begin + let #(x2_1, #(x2_2, x2_3)) = x2 in + let #(x4_1, #(x4_2, x4_3)) = x4 in + let #(x6_1, #(x6_2, x6_3)) = x6 in + let #(x8_1, #(x8_2, x8_3)) = x8 in + let sum = + Float.of_int x2_1 +. Float_u.to_float x2_2 +. x2_3 +. + Float.of_int x4_1 +. Float_u.to_float x4_2 +. x4_3 +. + Float.of_int x6_1 +. Float_u.to_float x6_2 +. x6_3 +. + Float.of_int x8_1 +. Float_u.to_float x8_2 +. x8_3 + in + let acc = go (k + 1) in + steps.(k) <- acc; + acc +. ((x1 +. x3 +. x5 +. x7 +. x9) *. sum) + end + in + go start_k + +let test3 () = + (* Test f3 *) + let steps = Array.init 10 (fun _ -> 0.0) in + let five_pi = f3 #(5, #3.14) #(steps, #0.0) in + print_floatu "Test 3, 5 * pi: " (five_pi ()); + Array.iteri (Printf.printf " Test 3, step %d: %.2f\n") steps; + + (* Test f3_manyargs + + (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 50.86 + 3 * (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 152.58 + 6 * (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 306.16 + 9 * (3.14 + 2.72 + 1.62 + 1.41 + 42.0) = 457.74 + + ( but we expect some floating point error ) + *) + let steps = Array.init 10 (fun _ -> 0.0) in + let x1 = 3.14 in + let x3 = 2.72 in + let x5 = 1.62 in + let x7 = 1.41 in + let x9 = 42.0 in + + (* these sum to 3 *) + let x2 = #(7, #(#40.0, 2.0)) in + let x4 = #(-23, #(#100.0, 9.0)) in + let x6 = #(-242, #(#5.5, 84.5)) in + let x8 = #(-2, #(#20.0, 2.0)) in + + let f3_manyargs = f3_manyargs #(4,8) x1 x2 x3 x4 x5 x6 x7 x8 x9 steps in + print_float "Test 3, 610.68: " (f3_manyargs ()); + Array.iteri (Printf.printf " Test 3, step %d: %.2f\n") steps + +let _ = test3 () + +(*********************************************) +(* Test 4: Partial and indirect applications *) + +let[@inline never] test4 () = + let one = #(-1, #(#1.33, 0.67)) in + let two = #(-5, #(#12.7, -5.7)) in + + (* Simple indirect call *) + let[@inline never] go f = f one two in + let #(x1, x2) = #(go add_t, go sub_t) in + print_t_sum "Test 4, 1 + 2" x1; + print_t_sum "Test 4, 1 - 2" x2; + + (* partial application to an unboxed tuple and with one remaining *) + let steps = Array.init 10 (fun _ -> 0.0) in + let f = Sys.opaque_identity (f3 #(5,#3.14)) in + let five_pi = f #(steps,#0.0) in + print_floatu "Test 4, 5 * pi: " (five_pi ()); + Array.iteri (Printf.printf " Test 4, step %d: %.2f\n") steps; + + (* That test again, but making f3 also opaque to prevent expansion of the + partial application. *) + let f3 = Sys.opaque_identity f3 in + + let steps = Array.init 10 (fun _ -> 0.0) in + let f = Sys.opaque_identity (f3 #(5,#3.14)) in + let five_pi = f #(steps,#0.0) in + print_floatu "Test 4, 5 * pi: " (five_pi ()); + Array.iteri (Printf.printf " Test 4, step %d: %.2f\n") steps + +let _ = test4 () + +(****************************) +(* Test 5: Over application *) + +let[@inline never] f5 n m = + let[@inline never] go f = + f (add_t n m) + in + go + +let test5 () = + let one = #(-1, #(#1.33, 0.67)) in + let pi = #(1, #(#2.0, 0.14)) in + let e = #(1, #(#0.1, 1.62)) in + let _ : unit = + f5 pi e + (fun n s m -> print_t_sum s (add_t n m)) "Test 5, pi+e+1" + one + in + () + +let _ = test5 () + +(*************************************) +(* Test 6: methods on unboxed tuples *) + +(* CR layouts: add tests that unboxed tuples in objects, once that is + allowed. *) + +(* unboxed tuple args and returns *) +let f6_1 () = object + method f6_m1 t1 t2 t3 = + add_t (sub_t t1 t2) t3 +end + +(* recursion *) +let f6_2 n = object(self) + method f6_m2 n3 tup f = + if n3 = ((Sys.opaque_identity fst) n) + ((Sys.opaque_identity snd) n) then + tup + else f (self#f6_m2 (n3+1) tup f) +end + +(* overapplication to unboxed tuple and value args *) +let f6_3 n k = object + method f6_m3 n3 tup f = + let n = ((Sys.opaque_identity fst) n) + ((Sys.opaque_identity snd) n) in + f (n + k + n3) tup +end + +let test6 () = + let one = #(-1, #(#1.33, 0.67)) in + let pi = #(1, #(#2.0, 0.14)) in + let e = #(1, #(#0.1, 1.62)) in + let add3 n (m, k) = n + m + k in + + (* (3.14 - 2.72) + 1 = 1.42 *) + let o = (Sys.opaque_identity f6_1) () in + print_t_sum "Test 6, 1.42" + (o#f6_m1 pi e one); + + (* 4.25 * 8 = 34 *) + let t_4_25 = #(2, #(#1.1, 1.15)) in + let o = (Sys.opaque_identity f6_2) (4,7) in + let result = o#f6_m2 8 t_4_25 (fun x -> add_t x x) in + print_t_sum "Test 6, 34.00" result; + + (* (1 + 2 + 3 + (-2) + (-12) + 4) * (2.72 + (-1) + 10) = -46.88 *) + let o = (Sys.opaque_identity f6_3) (1,2) 3 in + let negative_one = #(-3, #(#1.33, 0.67)) in + let ten = #(-1, #(#13.2, -2.2)) in + let result = + o#f6_m3 (-2) e + (fun[@inline never] i m1 m2 n m3 -> + Float.of_int (add3 i n) *. (t_sum m1 +. t_sum m2 +. t_sum m3)) + negative_one (-12,4) ten + in + print_float "Test 6, -46.88" result + +let _ = test6 () + +(*************************************) +(* Test 7: letop with unboxed tuples *) + +let ( let* ) x f = + let one = #(0, #(#1.0, 0.0)) in + f Float_u.(add_t x one) + +let _ = + let* pi_plus_one = #(1, #(#2.0, 0.14)) in + print_t_sum "Test 7, 4.14" pi_plus_one + +let ( let* ) x (f : _ -> t) = + let one = #(0, #(#1.0, 0.0)) in + add_t one (f x) +let ( and* ) x y = (x, t_sum y) +let _ = + let one = #(0, #(#1.0, 0.0)) in + let e = #(1, #(#0.1, 1.62)) in + let result = + let* x = 42 + and* y = one + and* z = e in + #(42, #(Float_u.of_float y, z)) + in + print_t_sum "Test 7, 46.72" result + +(****************************************************) +(* Test 8: Labeled, reordered, and partial patterns *) + +type t_labeled_unboxed_tuple = + #(x:int * float# * x:float# * float * y:int64#) + +let reverse_with_reordered_match (t : t_labeled_unboxed_tuple) = + match t with + | #(~y, ~x:x1, uf, ~x:x2, bf) -> + #(y, bf, x2, uf, x1) + +let extract_y t = + let #(~y, ..) : t_labeled_unboxed_tuple = t in + y + +let _ = + let t = #(~x:1, #2.2, ~x:#3.3, 4.4, ~y:#5L) in + let #(a,b,c,d,e) = (reverse_with_reordered_match[@inlined]) t in + Printf.printf "Test 8, reverse (inlined): %d, %.2f, %.2f, %.2f, %d\n" + (Int64_u.to_int a) b (Float_u.to_float c) (Float_u.to_float d) e; + let #(a,b,c,d,e) = (reverse_with_reordered_match[@inlined never]) t in + Printf.printf "Test 8, reverse (not inlined): %d, %.2f, %.2f, %.2f, %d\n" + (Int64_u.to_int a) b (Float_u.to_float c) (Float_u.to_float d) e; + let a = (extract_y[@inlined]) t in + Printf.printf "Test 8, extract y (inlined): %d\n" (Int64_u.to_int a); + let a = (extract_y[@inlined never]) t in + Printf.printf "Test 8, extract y (not inlined): %d\n" (Int64_u.to_int a) + +(**********************************) +(* Test 9: Continuations / @local *) + +let print4 prefix #(#(z,y),x,w) = + Printf.printf "%s: #(#(%.1f, %d), %.1f, %s)\n" prefix z y (Float_u.to_float x) w + +let _ = + let[@local] swap #(w, x, #(y, z)) = #(#(z, y), x, w) in + let[@inline never] g i p1 p2 = + let z = + if i < 0 then + swap p1 + else if i = 0 then + swap p2 + else + swap #("hi", #42.0, #(84, 3.0)) + in z + in + print4 "Test 9, #(#(3.0, 2), 1.0, a)" + (g (-1) #("a", #1.0, #(2, 3.0)) #("a",#4.0,#(5,6.0))); + + let[@local] swap #(w, x, #(y, z)) = #(#(z, y), x, w) in + let[@inline never] g i p1 p2 = + let z = + if i < 0 then + swap p1 + else if i = 0 then + swap p2 + else + swap #("hi", #42.0, #(84, 3.0)) + in z + in + print4 "Test 9, #(#(6.0, 5), 4.0, b)" + (g 0 #("a", #1.0, #(2, 3.0)) #("b",#4.0,#(5,6.0))); + + let[@local] swap #(w, x, #(y, z)) = #(#(z, y), x, w) in + let[@inline never] g i p1 p2 = + let z = + if i < 0 then + swap p1 + else if i = 0 then + swap p2 + else + swap #("hi", #42.0, #(84, 3.0)) + in z + in + print4 "Test 9, #(#(3.0, 84), 42.0, hi)" + (g 1 #("a", #1.0, #(2, 3.0)) #("b",#4.0,#(5,6.0))) + +(**************************) +(* Test 10: Loopification *) + +let print4 prefix #(w,#(x,y),z) = + Printf.printf "%s: #(%.1f, #(%.1f, %d), %d)\n" prefix + (Float_u.to_float w) x y z + +let[@loop] rec fib n (#(w, #(x, y), z) as p) = + let w = Float_u.to_float w in + if Float.compare w (Float.of_int n) > 0 then p else + let next = Float_u.of_float (w +. x) in + fib n #(next, #(w, Float.to_int x), y) + +let _ = + print4 "Test 10, #(1.0, #(0.0, 0), 0)" (fib 0 #(#1.0,#(0.0,0),0)); + print4 "Test 10, #(5.0, #(3.0, 2), 1))" (fib 4 #(#1.0,#(0.0,0),0)); + print4 "Test 10, #(144.0, #(89.0, 55), 34)" (fib 100 #(#1.0,#(0.0,0),0)); + diff --git a/ocaml/testsuite/tests/typing-layouts-products/unboxed_tuples.reference b/ocaml/testsuite/tests/typing-layouts-products/unboxed_tuples.reference new file mode 100644 index 00000000000..54a52fc7cd1 --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-products/unboxed_tuples.reference @@ -0,0 +1,76 @@ +Test 1, twice pi inlined: 6.28 +Test 1, twice pi not inlined: 6.28 +Test 1, 14/3 inlined: #(4,2) +Test 1, 14/3 not inlined: #(4,2) +Test 1, #(6,#(15,24)) inlined: #(6,#(15,24)) +Test 1, #(6,#(15,24)) not inlined: #(6,#(15,24)) +Test 2, add pi twice: 6.28 +Test 2, add pi four times: 12.56 +Test 2, increment pi twice: 5.14 +Test 2, increment pi four times: 7.14 +Test 2, e times four: 18.88 +Test 2, pi times sixteen: 50.24 +Test 2, pi times sixteen again: 50.24 +Test 2, pi minus four: -0.86 +Test 3, 5 * pi: : 15.70 + Test 3, step 0: 12.56 + Test 3, step 1: 9.42 + Test 3, step 2: 6.28 + Test 3, step 3: 3.14 + Test 3, step 4: 0.00 + Test 3, step 5: 0.00 + Test 3, step 6: 0.00 + Test 3, step 7: 0.00 + Test 3, step 8: 0.00 + Test 3, step 9: 0.00 +Test 3, 610.68: : 610.68 + Test 3, step 0: 0.00 + Test 3, step 1: 0.00 + Test 3, step 2: 0.00 + Test 3, step 3: 0.00 + Test 3, step 4: 458.01 + Test 3, step 5: 305.34 + Test 3, step 6: 152.67 + Test 3, step 7: 0.00 + Test 3, step 8: 0.00 + Test 3, step 9: 0.00 +Test 4, 1 + 2: 3.00 +Test 4, 1 - 2: -1.00 +Test 4, 5 * pi: : 15.70 + Test 4, step 0: 12.56 + Test 4, step 1: 9.42 + Test 4, step 2: 6.28 + Test 4, step 3: 3.14 + Test 4, step 4: 0.00 + Test 4, step 5: 0.00 + Test 4, step 6: 0.00 + Test 4, step 7: 0.00 + Test 4, step 8: 0.00 + Test 4, step 9: 0.00 +Test 4, 5 * pi: : 15.70 + Test 4, step 0: 12.56 + Test 4, step 1: 9.42 + Test 4, step 2: 6.28 + Test 4, step 3: 3.14 + Test 4, step 4: 0.00 + Test 4, step 5: 0.00 + Test 4, step 6: 0.00 + Test 4, step 7: 0.00 + Test 4, step 8: 0.00 + Test 4, step 9: 0.00 +Test 5, pi+e+1: 6.86 +Test 6, 1.42: 1.42 +Test 6, 34.00: 34.00 +Test 6, -46.88: -46.88 +Test 7, 4.14: 4.14 +Test 7, 46.72: 46.72 +Test 8, reverse (inlined): 5, 4.40, 3.30, 2.20, 1 +Test 8, reverse (not inlined): 5, 4.40, 3.30, 2.20, 1 +Test 8, extract y (inlined): 5 +Test 8, extract y (not inlined): 5 +Test 9, #(#(3.0, 2), 1.0, a): #(#(3.0, 2), 1.0, a) +Test 9, #(#(6.0, 5), 4.0, b): #(#(6.0, 5), 4.0, b) +Test 9, #(#(3.0, 84), 42.0, hi): #(#(3.0, 84), 42.0, hi) +Test 10, #(1.0, #(0.0, 0), 0): #(1.0, #(0.0, 0), 0) +Test 10, #(5.0, #(3.0, 2), 1)): #(5.0, #(3.0, 2), 1) +Test 10, #(144.0, #(89.0, 55), 34): #(144.0, #(89.0, 55), 34) diff --git a/ocaml/testsuite/tests/typing-layouts-products/unboxed_tuples_disabled.compilers.reference b/ocaml/testsuite/tests/typing-layouts-products/unboxed_tuples_disabled.compilers.reference new file mode 100644 index 00000000000..3b63d645c14 --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-products/unboxed_tuples_disabled.compilers.reference @@ -0,0 +1,4 @@ +File "unboxed_tuples.ml", line 57, characters 22-28: +57 | let print_ints prefix #(x,y) = Printf.printf "%s: #(%d,%d)\n" prefix x y + ^^^^^^ +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used diff --git a/ocaml/testsuite/tests/typing-layouts-products/unboxed_tuples_stable.compilers.reference b/ocaml/testsuite/tests/typing-layouts-products/unboxed_tuples_stable.compilers.reference new file mode 100644 index 00000000000..3b63d645c14 --- /dev/null +++ b/ocaml/testsuite/tests/typing-layouts-products/unboxed_tuples_stable.compilers.reference @@ -0,0 +1,4 @@ +File "unboxed_tuples.ml", line 57, characters 22-28: +57 | let print_ints prefix #(x,y) = Printf.printf "%s: #(%d,%d)\n" prefix x y + ^^^^^^ +Error: This construct requires the beta version of the extension "layouts", which is disabled and cannot be used diff --git a/ocaml/testsuite/tests/typing-layouts/annots.ml b/ocaml/testsuite/tests/typing-layouts/annots.ml index 89717d73267..6ebb79a4c31 100644 --- a/ocaml/testsuite/tests/typing-layouts/annots.ml +++ b/ocaml/testsuite/tests/typing-layouts/annots.ml @@ -848,7 +848,7 @@ Line 1, characters 29-36: ^^^^^^^ Error: This pattern matches values of type a but a pattern was expected which matches values of type - ('a : '_representable_layout_1) + ('a : '_representable_layout_203) The layout of a is any because of the annotation on the abstract type declaration for a. But the layout of a must be representable diff --git a/ocaml/testsuite/tests/typing-layouts/basics.ml b/ocaml/testsuite/tests/typing-layouts/basics.ml index a479236d955..6f6d441d77d 100644 --- a/ocaml/testsuite/tests/typing-layouts/basics.ml +++ b/ocaml/testsuite/tests/typing-layouts/basics.ml @@ -88,7 +88,7 @@ Line 4, characters 35-41: 4 | type 'a s = 'a -> int constraint 'a = t ^^^^^^ Error: The type constraints are not consistent. - Type ('a : '_representable_layout_1) is not compatible with type t + Type ('a : '_representable_layout_2) is not compatible with type t The layout of t is any because of the definition of t at line 2, characters 2-14. But the layout of t must be representable @@ -352,7 +352,7 @@ Line 4, characters 35-41: 4 | type 'a s = 'a -> int constraint 'a = t ^^^^^^ Error: The type constraints are not consistent. - Type ('a : '_representable_layout_2) is not compatible with type t + Type ('a : '_representable_layout_219) is not compatible with type t The layout of t is any because of the definition of t at line 2, characters 2-14. But the layout of t must be representable @@ -369,7 +369,7 @@ Line 4, characters 35-41: 4 | type 'a s = int -> 'a constraint 'a = t ^^^^^^ Error: The type constraints are not consistent. - Type ('a : '_representable_layout_3) is not compatible with type t + Type ('a : '_representable_layout_221) is not compatible with type t The layout of t is any because of the definition of t at line 2, characters 2-14. But the layout of t must be representable @@ -382,7 +382,7 @@ Line 1, characters 20-32: 1 | let f1 () : t_any = assert false;; ^^^^^^^^^^^^ Error: This expression has type t_any but an expression was expected of type - ('a : '_representable_layout_4) + ('a : '_representable_layout_224) The layout of t_any is any because of the definition of t_any at line 5, characters 0-18. But the layout of t_any must be representable @@ -396,7 +396,7 @@ Line 1, characters 7-18: ^^^^^^^^^^^ Error: This pattern matches values of type t_any but a pattern was expected which matches values of type - ('a : '_representable_layout_5) + ('a : '_representable_layout_226) The layout of t_any is any because of the definition of t_any at line 5, characters 0-18. But the layout of t_any must be representable @@ -1904,7 +1904,7 @@ Line 1, characters 10-22: 1 | let () = (assert false : t_any); () ^^^^^^^^^^^^ Error: This expression has type t_any but an expression was expected of type - ('a : '_representable_layout_6) + ('a : '_representable_layout_614) because it is in the left-hand side of a sequence The layout of t_any is any because of the definition of t_any at line 5, characters 0-18. @@ -1923,7 +1923,7 @@ Line 1, characters 25-37: 1 | let () = while false do (assert false : t_any); done ^^^^^^^^^^^^ Error: This expression has type t_any but an expression was expected of type - ('a : '_representable_layout_7) + ('a : '_representable_layout_616) because it is in the body of a while-loop The layout of t_any is any because of the definition of t_any at line 5, characters 0-18. @@ -1942,7 +1942,7 @@ Line 1, characters 28-40: 1 | let () = for i = 0 to 0 do (assert false : t_any); done ^^^^^^^^^^^^ Error: This expression has type t_any but an expression was expected of type - ('a : '_representable_layout_8) + ('a : '_representable_layout_618) because it is in the body of a for-loop The layout of t_any is any because of the definition of t_any at line 5, characters 0-18. diff --git a/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml b/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml index f401b949e75..1096449182b 100644 --- a/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml +++ b/ocaml/testsuite/tests/typing-layouts/basics_alpha.ml @@ -74,7 +74,7 @@ Line 4, characters 35-41: 4 | type 'a s = 'a -> int constraint 'a = t ^^^^^^ Error: The type constraints are not consistent. - Type ('a : '_representable_layout_1) is not compatible with type t + Type ('a : '_representable_layout_6) is not compatible with type t The layout of t is any because of the definition of t at line 2, characters 2-14. But the layout of t must be representable @@ -91,7 +91,7 @@ Line 4, characters 35-41: 4 | type 'a s = int -> 'a constraint 'a = t ^^^^^^ Error: The type constraints are not consistent. - Type ('a : '_representable_layout_2) is not compatible with type t + Type ('a : '_representable_layout_8) is not compatible with type t The layout of t is any because of the definition of t at line 2, characters 2-14. But the layout of t must be representable @@ -104,7 +104,7 @@ Line 1, characters 20-32: 1 | let f1 () : t_any = assert false;; ^^^^^^^^^^^^ Error: This expression has type t_any but an expression was expected of type - ('a : '_representable_layout_3) + ('a : '_representable_layout_11) The layout of t_any is any because of the definition of t_any at line 1, characters 0-18. But the layout of t_any must be representable @@ -118,7 +118,7 @@ Line 1, characters 7-18: ^^^^^^^^^^^ Error: This pattern matches values of type t_any but a pattern was expected which matches values of type - ('a : '_representable_layout_4) + ('a : '_representable_layout_13) The layout of t_any is any because of the definition of t_any at line 1, characters 0-18. But the layout of t_any must be representable @@ -1831,7 +1831,7 @@ Line 1, characters 10-22: 1 | let () = (assert false : t_any); () ^^^^^^^^^^^^ Error: This expression has type t_any but an expression was expected of type - ('a : '_representable_layout_5) + ('a : '_representable_layout_529) because it is in the left-hand side of a sequence The layout of t_any is any because of the definition of t_any at line 1, characters 0-18. @@ -1850,7 +1850,7 @@ Line 1, characters 25-37: 1 | let () = while false do (assert false : t_any); done ^^^^^^^^^^^^ Error: This expression has type t_any but an expression was expected of type - ('a : '_representable_layout_6) + ('a : '_representable_layout_531) because it is in the body of a while-loop The layout of t_any is any because of the definition of t_any at line 1, characters 0-18. @@ -1869,7 +1869,7 @@ Line 1, characters 28-40: 1 | let () = for i = 0 to 0 do (assert false : t_any); done ^^^^^^^^^^^^ Error: This expression has type t_any but an expression was expected of type - ('a : '_representable_layout_7) + ('a : '_representable_layout_533) because it is in the body of a for-loop The layout of t_any is any because of the definition of t_any at line 1, characters 0-18. diff --git a/ocaml/testsuite/tests/typing-layouts/layout_poly.ml b/ocaml/testsuite/tests/typing-layouts/layout_poly.ml index 50528a488fb..9b47fe285ab 100644 --- a/ocaml/testsuite/tests/typing-layouts/layout_poly.ml +++ b/ocaml/testsuite/tests/typing-layouts/layout_poly.ml @@ -34,7 +34,7 @@ Line 3, characters 14-36: 3 | let f () = id (assert false : t_any) ^^^^^^^^^^^^^^^^^^^^^^ Error: This expression has type t_any but an expression was expected of type - ('a : '_representable_layout_1) + ('a : '_representable_layout_9) The layout of t_any is any because of the definition of t_any at line 3, characters 0-16. But the layout of t_any must be representable diff --git a/ocaml/testsuite/tests/typing-layouts/printing.ml b/ocaml/testsuite/tests/typing-layouts/printing.ml index fe17520332e..467575c6ffe 100644 --- a/ocaml/testsuite/tests/typing-layouts/printing.ml +++ b/ocaml/testsuite/tests/typing-layouts/printing.ml @@ -16,11 +16,11 @@ Lines 3-5, characters 6-3: 5 | end Error: Signature mismatch: Modules do not match: - sig val f : ('a : '_representable_layout_1). unit -> 'a -> unit end + sig val f : ('a : '_representable_layout_4). unit -> 'a -> unit end is not included in sig val f : int -> bool -> char end Values do not match: - val f : ('a : '_representable_layout_1). unit -> 'a -> unit + val f : ('a : '_representable_layout_4). unit -> 'a -> unit is not included in val f : int -> bool -> char The type unit -> 'a -> unit is not compatible with the type diff --git a/ocaml/testsuite/tests/typing-modes/tuple_modes.ml b/ocaml/testsuite/tests/typing-modes/tuple_modes.ml index d4c622d3281..fa971b8414c 100644 --- a/ocaml/testsuite/tests/typing-modes/tuple_modes.ml +++ b/ocaml/testsuite/tests/typing-modes/tuple_modes.ml @@ -1,14 +1,19 @@ (* TEST + flags = "-extension layouts_beta"; expect; *) (* Test the tricky business of tuple_modes *) let use_global : 'a @ global -> unit = fun _ -> () +let use_global_product : ('a : value & value). 'a @ global -> unit = fun _ -> () let use_local : 'a @ local -> unit = fun _ -> () +let use_local_product : ('a : value & value). 'a @ local -> unit = fun _ -> () [%%expect{| val use_global : 'a -> unit = +val use_global_product : ('a : value & value). 'a -> unit = val use_local : local_ 'a -> unit = +val use_local_product : ('a : value & value). local_ 'a -> unit = |}] let f x = @@ -25,6 +30,20 @@ Error: This value escapes its region. Hint: Cannot return a local value without an "exclave_" annotation. |}] +let f x = + let #(_, x) : _ = + #(42, local_ (Some x)) + in + x + ;; +[%%expect{| +Line 5, characters 4-5: +5 | x + ^ +Error: This value escapes its region. + Hint: Cannot return a local value without an "exclave_" annotation. +|}] + let f e0 (e1 @ local) = match e0, e1 with | x0, x1 -> use_global x0; use_local x1; () @@ -32,6 +51,13 @@ let f e0 (e1 @ local) = val f : 'a -> local_ 'b -> unit = |}] +let f e0 (e1 @ local) = + match #(e0, e1) with + | #(x0, x1) -> use_global x0; use_local x1; () +[%%expect{| +val f : 'a -> local_ 'b -> unit = +|}] + let f e0 (e1 @ local) = match e0, e1 with | x0, x1 -> use_global x0; use_global x1; () @@ -42,6 +68,16 @@ Line 3, characters 42-44: Error: This value escapes its region. |}] +let f e0 (e1 @ local) = + match #(e0, e1) with + | #(x0, x1) -> use_global x0; use_global x1; () +[%%expect{| +Line 3, characters 45-47: +3 | | #(x0, x1) -> use_global x0; use_global x1; () + ^^ +Error: This value escapes its region. +|}] + let f e0 (e1 @ local) = match e0, e1 with | x0, x1 when x0 = x1 -> use_global x0; use_local x1; () @@ -53,6 +89,17 @@ Line 4, characters 22-23: Error: This value escapes its region. |}] +let f e0 (e1 @ local) = + match #(e0, e1) with + | #(x0, x1) when x0 = x1 -> use_global x0; use_local x1; () + | x -> use_global_product x; () +[%%expect{| +Line 4, characters 30-31: +4 | | x -> use_global_product x; () + ^ +Error: This value escapes its region. +|}] + let f e0 (e1 @ local) = match e0, e1 with @@ -62,8 +109,17 @@ let f e0 (e1 @ local) = val f : 'a -> local_ 'a -> unit = |}] -(* we can return [e1], because it's regional. We can't return [x] - (or its component) because [x] is allocated in the current region. *) +let f e0 (e1 @ local) = + match #(e0, e1) with + | #(x0, x1) when x0 = x1 -> use_global x0; use_local x1; () + | x -> use_local_product x; () +[%%expect{| +val f : 'a -> local_ 'a -> unit = +|}] + +(* we can return [e1], because it's regional. We can't return [x] (or its + component) because [x] is allocated in the current region. But when there is + no allocation, as in the unboxed version just below, this is allowed. *) let f e0 (e1 @ local) = match e0, e1 with | x0, x1 when x0 = x1 -> use_global x0; use_local x1; e1 @@ -76,6 +132,14 @@ Error: This value escapes its region. Hint: Cannot return a local value without an "exclave_" annotation. |}] +let f e0 (e1 @ local) = + match #(e0, e1) with + | #(x0, x1) when x0 = x1 -> use_global x0; use_local x1; e1 + | x -> use_local_product x; let #(x0, x1) = x in x0 +[%%expect{| +val f : 'a -> local_ 'a -> local_ 'a = +|}] + (* The value being matched upon is [local] in one branch, so the match result is [local]. *) let f b e0 (e1 @ local) (e @ local)= @@ -88,6 +152,16 @@ Line 3, characters 27-29: Error: This value escapes its region. |}] +let f b e0 (e1 @ local) (e @ local)= + match if b then #(e0, e1) else e with + | #(x0, x1) -> use_global x0; use_local x1; () +[%%expect{| +Line 3, characters 30-32: +3 | | #(x0, x1) -> use_global x0; use_local x1; () + ^^ +Error: This value escapes its region. +|}] + let f b e0 (e1 @ local) e2 e3 = match if b then e0, e1 else e2, e3 with | x0, x1 -> use_global x0; use_local x1; () @@ -95,6 +169,13 @@ let f b e0 (e1 @ local) e2 e3 = val f : bool -> 'a -> local_ 'b -> 'a -> 'b -> unit = |}] +let f b e0 (e1 @ local) e2 e3 = + match if b then #(e0, e1) else #(e2, e3) with + | #(x0, x1) -> use_global x0; use_local x1; () +[%%expect{| +val f : bool -> 'a -> local_ 'b -> 'a -> 'b -> unit = +|}] + let f b e0 (e1 @ local) e2 e3 = match if b then e0, e1 else e2, e3 with | x0, x1 -> use_global x0; use_global x1; () @@ -104,3 +185,34 @@ Line 3, characters 42-44: ^^ Error: This value escapes its region. |}] + +let f b e0 (e1 @ local) e2 e3 = + match if b then #(e0, e1) else #(e2, e3) with + | #(x0, x1) -> use_global x0; use_global x1; () +[%%expect{| +Line 3, characters 45-47: +3 | | #(x0, x1) -> use_global x0; use_global x1; () + ^^ +Error: This value escapes its region. +|}] + +(* An unboxed tuple is not an allocation, but a regular tuple is *) +let f_unboxed_tuple (local_ a) (local_ b) = + let t = #(a, b) in + let #(a', _) = t in + a' +[%%expect{| +val f_unboxed_tuple : local_ 'a -> local_ 'b -> local_ 'a = +|}] + +let f_boxed_tuple (local_ a) (local_ b) = + let t = (a, b) in + let (a', _) = t in + a' +[%%expect{| +Line 4, characters 2-4: +4 | a' + ^^ +Error: This value escapes its region. + Hint: Cannot return a local value without an "exclave_" annotation. +|}] diff --git a/ocaml/testsuite/tests/typing-unique/unique_analysis.ml b/ocaml/testsuite/tests/typing-unique/unique_analysis.ml index 7b4cf898d7d..8a8db6e03eb 100644 --- a/ocaml/testsuite/tests/typing-unique/unique_analysis.ml +++ b/ocaml/testsuite/tests/typing-unique/unique_analysis.ml @@ -1,9 +1,11 @@ - (* TEST - flags += "-extension unique"; +(* TEST + flags += "-extension unique -extension layouts_beta"; expect; *) (* This file is to test uniqueness_analysis.ml *) +(* CR layouts v7.1: When tuples are out of beta, this test no longer needs + -extension layouts_beta *) (* First some helper functions *) let unique_id : 'a. unique_ 'a -> unique_ 'a = fun x -> x @@ -782,3 +784,29 @@ Line 3, characters 20-21: ^ |}] + +let foo () = + let t = #("hello", "world") in + let unique_use_tuple : ('a : value & value). unique_ 'a -> unit = fun _ -> () in + unique_use_tuple t; + let #(_, _) = t in + () +[%%expect{| +val foo : unit -> unit = +|}] + +let foo () = + let t = ("hello", "world") in + ignore (unique_id t); + let (_, _) = t in + () +[%%expect{| +Line 4, characters 6-12: +4 | let (_, _) = t in + ^^^^^^ +Error: This value is read from here, but it has already been used as unique: +Line 3, characters 20-21: +3 | ignore (unique_id t); + ^ + +|}] diff --git a/ocaml/toplevel/genprintval.ml b/ocaml/toplevel/genprintval.ml index 71d972497ea..ecaf4d1bc41 100644 --- a/ocaml/toplevel/genprintval.ml +++ b/ocaml/toplevel/genprintval.ml @@ -257,10 +257,11 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct printing to avoid descending into NULL. (This module uses lots of unsafe Obj features.) *) - | Sort Value -> Print_as_value - | Sort Void -> Print_as "" + | Base Value -> Print_as_value + | Base Void -> Print_as "" | Any -> Print_as "" - | Sort (Float64 | Float32 | Bits32 | Bits64 | Word) -> Print_as "" + | Base (Float64 | Float32 | Bits32 | Bits64 | Word) -> Print_as "" + | Product _ -> Print_as "" let outval_of_value max_steps max_depth check_depth env obj ty = @@ -298,6 +299,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct Oval_stuff "" | Ttuple(labeled_tys) -> Oval_tuple (tree_of_labeled_val_list 0 depth obj labeled_tys) + | Tunboxed_tuple(labeled_tys) -> + Oval_unboxed_tuple + (tree_of_labeled_val_list 0 depth obj labeled_tys) | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list -> if O.is_block obj then diff --git a/ocaml/typing/btype.ml b/ocaml/typing/btype.ml index 0a063cf8317..cfe5c6ebe3b 100644 --- a/ocaml/typing/btype.ml +++ b/ocaml/typing/btype.ml @@ -270,6 +270,7 @@ let fold_type_expr f init ty = let result = f init ty1 in f result ty2 | Ttuple l -> List.fold_left f init (List.map snd l) + | Tunboxed_tuple l -> List.fold_left f init (List.map snd l) | Tconstr (_, l, _) -> List.fold_left f init l | Tobject(ty, {contents = Some (_, p)}) -> let result = f init ty in @@ -450,6 +451,8 @@ let rec copy_type_desc ?(keep_names=false) f = function if keep_names then tv else Tvar { name=None; jkind } | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c) | Ttuple l -> Ttuple (List.map (fun (label, t) -> label, f t) l) + | Tunboxed_tuple l -> + Tunboxed_tuple (List.map (fun (label, t) -> label, f t) l) | Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil) | Tobject(ty, {contents = Some (p, tl)}) -> Tobject (f ty, ref (Some(p, List.map f tl))) diff --git a/ocaml/typing/ctype.ml b/ocaml/typing/ctype.ml index 81a7cfe7215..1616003bed1 100644 --- a/ocaml/typing/ctype.ml +++ b/ocaml/typing/ctype.ml @@ -527,7 +527,6 @@ let rec filter_row_fields erase = function link_row_field_ext ~inside:f rf_absent; fi | _ -> p :: fi - (* Ensure all mode variables are fully determined *) let remove_mode_and_jkind_variables ty = let visited = ref TypeSet.empty in @@ -796,6 +795,9 @@ let rec generalize_spine ty = | Ttuple tyl -> set_level ty generic_level; List.iter (fun (_,t) -> generalize_spine t) tyl + | Tunboxed_tuple tyl -> + set_level ty generic_level; + List.iter (fun (_,t) -> generalize_spine t) tyl | Tpackage (_, fl) -> set_level ty generic_level; List.iter (fun (_n, ty) -> generalize_spine ty) fl @@ -1977,7 +1979,7 @@ let rec extract_concrete_typedecl env ty = end end | Tpoly(ty, _) -> extract_concrete_typedecl env ty - | Tarrow _ | Ttuple _ | Tobject _ | Tfield _ | Tnil + | Tarrow _ | Ttuple _ | Tunboxed_tuple _ | Tobject _ | Tfield _ | Tnil | Tvariant _ | Tpackage _ -> Has_no_typedecl | Tvar _ | Tunivar _ -> May_have_typedecl | Tlink _ | Tsubst _ -> assert false @@ -2060,18 +2062,17 @@ let get_unboxed_type_approximation env ty = match get_unboxed_type_representation env ty with | Ok ty | Error ty -> ty -(* When computing a jkind, we distinguish two cases because some callers might - want to update the jkind. - - Jkind: We compute the jkind, and the type wasn't a variable. +(* When computing a jkind, we distinguish a few cases: + - Jkind: We computed the jkind, and the type wasn't a variable or an unboxed + product. - Var: The type was a var, we return the jkind and the type_expr it was in, - in case the caller wants to update it. *) -type jkind_result = + in case the caller wants to update it. + - Product: The type was an unboxed product, these are the components. +*) +type jkind_head = | Jkind of Jkind.t - | TyVar of Jkind.t * type_expr - -let jkind_of_result = function - | Jkind l -> l - | TyVar (l,_) -> l + | TyVar of type_expr * Jkind.t + | Product of type_expr list let tvariant_not_immediate row = (* if all labels are devoid of arguments, not a pointer *) @@ -2092,7 +2093,7 @@ let tvariant_not_immediate row = in some edge cases (when [get_unboxed_type_representation] ran out of fuel, or when the type is a Tconstr that is missing from the Env due to a missing cmi). *) -let rec estimate_type_jkind env ty = +let rec estimate_type_jkind_head env ty = let open Jkind in match get_desc ty with | Tconstr(p, _, _) -> begin @@ -2115,36 +2116,73 @@ let rec estimate_type_jkind env ty = This, however, still allows sort variables to get instantiated. *) Jkind jkind - | Tvar { jkind } -> TyVar (jkind, ty) + | Tvar { jkind } -> TyVar (ty, jkind) | Tarrow _ -> Jkind for_arrow | Ttuple _ -> Jkind (Builtin.value ~why:Tuple) + | Tunboxed_tuple ltys -> Product (List.map snd ltys) | Tobject _ -> Jkind (Builtin.value ~why:Object) | Tfield _ -> Jkind (Builtin.value ~why:Tfield) | Tnil -> Jkind (Builtin.value ~why:Tnil) | (Tlink _ | Tsubst _) -> assert false | Tunivar { jkind } -> Jkind jkind - | Tpoly (ty, _) -> estimate_type_jkind env ty + | Tpoly (ty, _) -> estimate_type_jkind_head env ty | Tpackage _ -> Jkind (Builtin.value ~why:First_class_module) +(* We parameterize [estimate_type_jkind] and [jkind_of_jkind_head] by a function + [expand_components] because some callers want expansion of types and others + don't. *) +let rec estimate_type_jkind env ~expand_components ty = + jkind_of_jkind_head env ~expand_components (estimate_type_jkind_head env ty) + +(* See [estimate_type_jkind] above for explanation of [expand_components]. *) +and jkind_of_jkind_head env ~expand_components jkind_head = + match jkind_head with + | Jkind l -> l + | TyVar (_, l) -> l + | Product tys -> + Jkind.Builtin.product ~why:Unboxed_tuple + (List.map (fun ty -> + estimate_type_jkind env ~expand_components (expand_components ty) + ) tys) + (**** checking jkind relationships ****) +(* This type represents jkind constraints that we weren't able prove yet, but + which might succeed either by further expanding the type or by modifying a + type variable (in which case the [ty] will be a type variable). *) +type type_jkind_sub_possible_failure = + { estimate : Jkind.t; + bound : Jkind.t; + ty : type_expr } + type type_jkind_sub_result = | Success - (* The [Type_var] case might still be "success"; caller should check. - We don't just report success here because if the caller unifies the - tyvar, error messages improve. *) - | Type_var of Jkind.t * type_expr - | Missing_cmi of Jkind.t * Path.t - | Failure of Jkind.t + | Type_vars of type_jkind_sub_possible_failure list + (* [Type_vars] indicates a possible success - the caller should check, and + possibly update the variables *) + | Missing_cmi of Path.t + | Failure of type_jkind_sub_possible_failure + (* [Failure] indicates we couldn't verify the constraint. However, further + expansion the type might make it possible to verify. *) let type_jkind_sub env ty jkind = - let shallow_check ty = - match estimate_type_jkind env ty with - | Jkind ty_jkind -> - if Jkind.sub ty_jkind jkind then Success else Failure ty_jkind - | TyVar (ty_jkind, ty) -> Type_var (ty_jkind, ty) + let jkind_est_of_results prefix_jkinds later_components = + (* [jkind_est_of_results] is used when we've reached an error state in the + middle of checking a product. In that case, we don't want to continue + with any further checks for later components of the product, but we do + need to get our best estimate so far of the kinds of those components, + because the error shows the product's computed jkind. *) + let jkinds = + List.rev_append prefix_jkinds + (List.map fst later_components) + in + Jkind.Builtin.product ~why:Unboxed_tuple jkinds in - (* The "fuel" argument here is used because we're duplicating the loop of + + (* Every function here returns the best jkind computed for the type or types + it is passed, along with whether the constraint check succeeded. + + The "fuel" argument is used because we're duplicating the loop of `get_unboxed_type_representation`, but performing jkind checking at each step. This allows to check examples like: @@ -2158,28 +2196,101 @@ let type_jkind_sub env ty jkind = ensure it's a valid argument to [t]. (We believe there are still loops like this that can occur, though, and may need a more principled solution later). *) - let rec loop ty fuel = + let rec expand_and_check_one fuel ty jkind = (* This is an optimization to avoid unboxing if we can tell the constraint is satisfied from the type_kind *) match get_desc ty with | Tconstr(p, _args, _abbrev) -> - let jkind_bound = + let jkind_estimate = try (Env.find_type p env).type_jkind with Not_found -> Jkind.Builtin.any ~why:(Missing_cmi p) in - if Jkind.sub jkind_bound jkind - then Success - else if fuel < 0 then Failure jkind_bound + if Jkind.sub jkind_estimate jkind + then jkind_estimate, Success + else if fuel < 0 then + jkind_estimate, + Failure { estimate = jkind_estimate; bound = jkind; ty } else begin match unbox_once env ty with - | Final_result ty -> shallow_check ty - | Stepped ty -> loop ty (fuel - 1) + | Final_result ty -> check_one fuel ty jkind + | Stepped ty -> expand_and_check_one (fuel - 1) ty jkind | Missing missing_cmi_for -> - Missing_cmi (jkind_bound, missing_cmi_for) + jkind_estimate, Missing_cmi missing_cmi_for end - | Tpoly (ty, _) -> loop ty fuel - | _ -> shallow_check ty + | Tpoly (ty, _) -> expand_and_check_one fuel ty jkind + | _ -> check_one fuel ty jkind + + (* Unlike [expand_and_check_one], this will not expand the type it is passed. + But, if that type turns out to be an unboxed product we may end up + expanding its components. *) + and check_one fuel ty jkind = + match estimate_type_jkind_head env ty with + | Jkind ty_jkind -> + let result = + if Jkind.sub ty_jkind jkind then Success else + Failure {estimate = ty_jkind; bound = jkind; ty} + in + ty_jkind, result + | TyVar (ty, ty_jkind) -> + ty_jkind, Type_vars [{ estimate = ty_jkind; bound = jkind; ty }] + | Product component_types as product -> + let jkinds = + Jkind.is_nary_product (List.length component_types) jkind + in + match jkinds with + | None -> + (* The upper bound is not a product, but the type is. This may be + OK if the upper bound has layout any. *) + let estimate = + jkind_of_jkind_head env ~expand_components:(fun x -> x) product + in + let result = + if Jkind.sub estimate jkind then Success else + Failure { estimate; bound = jkind; ty } + in + estimate, result + | Some jkinds -> + (* Note: here we "duplicate" the fuel, which may seem like + cheating. Fuel counts expansions, and its purpose is to guard against + infinitely expanding a recursive type. In a wide product, we many + need to expand many types shallowly, and that's fine. *) + let results = List.map2 (check_one fuel) component_types jkinds in + process_product_results fuel [] [] results + + (* Here, we are recusing down [results] is a list of the (unprocessed) results + from attempting to constrain a product jkind. There is one for each + component, and we process them individually into the accumulators [vars] + and [jkind_ests]. Those collect the [Type_vars] from the component checks + and the jkind estimate of each component, respectively + + [Failure]s in results may have occurred just because we haven't expanded + the component type enough yet, so we expand and check it again. *) + + and process_product_results fuel vars jkind_ests results = + match results with + | [] -> + let jkind = + Jkind.Builtin.product ~why:Unboxed_tuple (List.rev jkind_ests) + in + if vars = [] then jkind, Success else jkind, Type_vars vars + | (jkind_est, result) :: results -> + (* If the result is failure, we try again with expansion. *) + let jkind_est, result = + match result with + (* CR: We could refactor slightly so that we skip the shortcut check + in [expand_and_check_one] here. *) + | Failure { bound; ty } -> expand_and_check_one fuel ty bound + | Success | Type_vars _ | Missing_cmi _ -> jkind_est, result + in + let jkind_ests = jkind_est :: jkind_ests in + match result with + | Success -> process_product_results fuel vars jkind_ests results + | Type_vars vars' -> + process_product_results fuel (vars' @ vars) jkind_ests results + | Failure _ | Missing_cmi _ -> + let jkind = jkind_est_of_results jkind_ests results in + jkind, result in - loop ty 100 + expand_and_check_one 100 ty jkind (* The ~fixed argument controls what effects this may have on `ty`. If false, then we will update the jkind of type variables to make the check true, if @@ -2190,20 +2301,24 @@ let type_jkind_sub env ty jkind = correct on [any].) *) let constrain_type_jkind ~fixed env ty jkind = - match type_jkind_sub env ty jkind with + let ty_jkind, result = type_jkind_sub env ty jkind in + match result with | Success -> Ok () - | Type_var (ty_jkind, ty) -> - if fixed then Jkind.sub_or_error ty_jkind jkind else - let jkind_inter = - Jkind.intersection_or_error ~reason:Tyvar_refinement_intersection - ty_jkind jkind + | Type_vars tvs -> + let constrain_one_var { estimate; bound; ty } = + if fixed then Jkind.sub_or_error estimate bound else + let jkind_inter = + Jkind.intersection_or_error ~reason:Tyvar_refinement_intersection + estimate bound + in + Result.map (set_var_jkind ty) jkind_inter in - Result.map (set_var_jkind ty) jkind_inter - | Missing_cmi (ty_jkind, missing_cmi) -> + Misc.Stdlib.List.iter_until_error ~f:constrain_one_var tvs + | Missing_cmi missing_cmi -> Error Jkind.(Violation.of_ ~missing_cmi (Not_a_subjkind (History.update_reason ty_jkind (Missing_cmi missing_cmi), jkind))) - | Failure ty_jkind -> + | Failure _ -> Error (Jkind.Violation.of_ (Not_a_subjkind (ty_jkind, jkind))) let constrain_type_jkind ~fixed env ty jkind = @@ -2255,11 +2370,10 @@ let constrain_type_jkind_exn env texn ty jkind = | Ok _ -> () | Error err -> raise_for texn (Bad_jkind (ty,err)) -let estimate_type_jkind env typ = - jkind_of_result (estimate_type_jkind env typ) - let type_jkind env ty = - estimate_type_jkind env (get_unboxed_type_approximation env ty) + estimate_type_jkind env + ~expand_components:(get_unboxed_type_approximation env) + (get_unboxed_type_approximation env ty) let type_jkind_purely env ty = if !Clflags.principal || Env.has_local_constraints env then @@ -2272,6 +2386,10 @@ let type_jkind_purely env ty = else type_jkind env ty +let estimate_type_jkind env ty = + estimate_type_jkind env ~expand_components:(fun x -> x) + (get_unboxed_type_approximation env ty) + let type_sort ~why env ty = let jkind, sort = Jkind.of_new_sort_var ~why in match constrain_type_jkind env ty jkind with @@ -2318,7 +2436,7 @@ let check_and_update_generalized_ty_jkind ?name ~loc ty = might turn out later to be value. This is the conservative choice. *) Jkind.(Externality.le (get_externality_upper_bound jkind) External64 && match get_layout jkind with - | Some (Sort Value) | None -> true + | Some (Base Value) | None -> true | _ -> false) in if Language_extension.erasable_extensions_only () @@ -3568,6 +3686,8 @@ and unify3 env t1 t1' t2 t2' = end | (Ttuple labeled_tl1, Ttuple labeled_tl2) -> unify_labeled_list env labeled_tl1 labeled_tl2 + | (Tunboxed_tuple labeled_tl1, Tunboxed_tuple labeled_tl2) -> + unify_labeled_list env labeled_tl1 labeled_tl2 | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> if not (can_generate_equations ()) then unify_list env tl1 tl2 @@ -4662,6 +4782,9 @@ let rec moregen inst_nongen variance type_pairs env t1 t2 = | (Ttuple labeled_tl1, Ttuple labeled_tl2) -> moregen_labeled_list inst_nongen variance type_pairs env labeled_tl1 labeled_tl2 + | (Tunboxed_tuple labeled_tl1, Tunboxed_tuple labeled_tl2) -> + moregen_labeled_list inst_nongen variance type_pairs env + labeled_tl1 labeled_tl2 | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> begin match variance with @@ -5088,6 +5211,9 @@ let rec eqtype rename type_pairs subst env t1 t2 = | (Ttuple labeled_tl1, Ttuple labeled_tl2) -> eqtype_labeled_list rename type_pairs subst env labeled_tl1 labeled_tl2 + | (Tunboxed_tuple labeled_tl1, Tunboxed_tuple labeled_tl2) -> + eqtype_labeled_list rename type_pairs subst env labeled_tl1 + labeled_tl2 | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> eqtype_list rename type_pairs subst env tl1 tl2 @@ -5688,17 +5814,11 @@ let rec build_subtype env (visited : transient_expr list) then (newty (Tarrow((l,a',r'), t1', t2', commu_ok)), c) else (t, Unchanged) | Ttuple labeled_tlist -> - let tt = Transient_expr.repr t in - if memq_warn tt visited then (t, Unchanged) else - let visited = tt :: visited in - let labels, tlist = List.split labeled_tlist in - let tlist' = - List.map (build_subtype env visited loops posi level) tlist - in - let c = collect tlist' in - if c > Unchanged then - (newty (Ttuple (List.combine labels (List.map fst tlist'))), c) - else (t, Unchanged) + build_subtype_tuple env visited loops posi level t labeled_tlist + (fun x -> Ttuple x) + | Tunboxed_tuple labeled_tlist -> + build_subtype_tuple env visited loops posi level t labeled_tlist + (fun x -> Tunboxed_tuple x) | Tconstr(p, tl, abbrev) when level > 0 && generic_abbrev env p && safe_abbrev env t && not (has_constr_row' env t) -> @@ -5842,6 +5962,21 @@ let rec build_subtype env (visited : transient_expr list) | Tunivar _ | Tpackage _ -> (t, Unchanged) +and build_subtype_tuple env visited loops posi level t labeled_tlist + constructor = + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: visited in + let labels, tlist = List.split labeled_tlist in + let tlist' = + List.map (build_subtype env visited loops posi level) tlist + in + let c = collect tlist' in + if c > Unchanged then + (newty (constructor (List.combine labels (List.map fst tlist'))), c) + else (t, Unchanged) + + let enlarge_type env ty = warn := false; (* [level = 4] allows 2 expansions involving objects/variants *) @@ -5908,6 +6043,8 @@ let rec subtype_rec env trace t1 t2 cstrs = cstrs | (Ttuple tl1, Ttuple tl2) -> subtype_labeled_list env trace tl1 tl2 cstrs + | (Tunboxed_tuple tl1, Tunboxed_tuple tl2) -> + subtype_labeled_list env trace tl1 tl2 cstrs | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 -> cstrs | (Tconstr(p1, _tl1, _abbrev1), _) diff --git a/ocaml/typing/jkind.ml b/ocaml/typing/jkind.ml index 03f39495705..c223d661a03 100644 --- a/ocaml/typing/jkind.ml +++ b/ocaml/typing/jkind.ml @@ -34,95 +34,210 @@ type type_expr = Types.type_expr module Layout = struct open Jkind_types.Layout + type nonrec t = t + module Const = struct - type t = Sort.const layout + type t = Const.t = + | Any + | Base of Sort.base + | Product of t list let max = Any - let equal c1 c2 = + let rec equal c1 c2 = match c1, c2 with - | Sort s1, Sort s2 -> Sort.Const.equal s1 s2 + | Base b1, Base b2 -> Sort.equal_base b1 b2 | Any, Any -> true - | (Any | Sort _), _ -> false + | Product cs1, Product cs2 -> List.equal equal cs1 cs2 + | (Base _ | Any | Product _), _ -> false - let sub (c1 : t) (c2 : t) : Misc.Le_result.t = + let rec sub (c1 : t) (c2 : t) : Misc.Le_result.t = match c1, c2 with | _ when equal c1 c2 -> Equal | _, Any -> Less - | Any, Sort _ | Sort _, Sort _ -> Not_le + | Product consts1, Product consts2 -> + if List.compare_lengths consts1 consts2 = 0 + then Misc.Le_result.combine_list (List.map2 sub consts1 consts2) + else Not_le + | (Any | Base _ | Product _), _ -> Not_le + + module Static = struct + let value = Base Sort.Value + + let void = Base Sort.Void + + let float64 = Base Sort.Float64 + + let float32 = Base Sort.Float32 + + let word = Base Sort.Word + + let bits32 = Base Sort.Bits32 + + let bits64 = Base Sort.Bits64 + + let of_base : Sort.base -> t = function + | Value -> value + | Void -> void + | Float64 -> float64 + | Float32 -> float32 + | Word -> word + | Bits32 -> bits32 + | Bits64 -> bits64 + end + + include Static - let get_sort : t -> Sort.Const.t option = function - | Sort s -> Some s + let rec get_sort : t -> Sort.Const.t option = function | Any -> None + | Base b -> Some (Base b) + | Product ts -> + Option.map + (fun x -> Sort.Const.Product x) + (Misc.Stdlib.List.map_option get_sort ts) - let to_string : t -> _ = function - | Any -> "any" - | Sort Void -> "void" - | Sort Value -> "value" - | Sort Float64 -> "float64" - | Sort Float32 -> "float32" - | Sort Word -> "word" - | Sort Bits32 -> "bits32" - | Sort Bits64 -> "bits64" + let rec of_sort s = + match Sort.get s with + | Var _ -> None + | Base b -> Some (Static.of_base b) + | Product sorts -> + Option.map + (fun x -> Product x) + (Misc.Stdlib.List.map_option of_sort sorts) + + let to_string t = + let rec to_string nested (t : t) = + match t with + | Any -> "any" + | Base b -> Sort.to_string_base b + | Product ts -> + String.concat "" + [ (if nested then "(" else ""); + String.concat " & " (List.map (to_string true) ts); + (if nested then ")" else "") ] + in + to_string false t module Debug_printers = struct open Format - let t ppf = function - | Any -> fprintf ppf "Any" - | Sort s -> fprintf ppf "Sort %a" Sort.Const.Debug_printers.t s + let t ppf t = fprintf ppf "%s" (to_string t) end + + let rec of_sort_const : Sort.Const.t -> t = function + | Base b -> Base b + | Product consts -> Product (List.map of_sort_const consts) end - type t = Sort.t layout + module Debug_printers = struct + open Format - let of_const const : t = - match const with Sort s -> Sort (Const s) | Any -> Any + let rec t ppf = function + | Any -> fprintf ppf "Any" + | Sort s -> fprintf ppf "Sort %a" Sort.Debug_printers.t s + | Product ts -> + fprintf ppf "Product [ %a ]" + (pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ";@ ") t) + ts + end - let equate_or_equal ~allow_mutation t1 t2 = + let rec of_const (const : Const.t) : t = + match const with + | Any -> Any + | Base b -> Sort (Sort.of_base b) + | Product cs -> Product (List.map of_const cs) + + let rec to_sort = function + | Any -> None + | Sort s -> Some s + | Product ts -> to_product_sort ts + + and to_product_sort ts = + Option.map + (fun x -> Sort.Product x) + (Misc.Stdlib.List.map_option to_sort ts) + + let sort_equal_result ~allow_mutation result = + match (result : Sort.equate_result) with + | (Equal_mutated_first | Equal_mutated_second | Equal_mutated_both) + when not allow_mutation -> + Misc.fatal_errorf "Jkind.equal: Performed unexpected mutation" + | Unequal -> false + | Equal_no_mutation | Equal_mutated_first | Equal_mutated_second + | Equal_mutated_both -> + true + + let rec equate_or_equal ~allow_mutation t1 t2 = match t1, t2 with - | Sort s1, Sort s2 -> ( - match Sort.equate_tracking_mutation s1 s2 with - | (Equal_mutated_first | Equal_mutated_second) when not allow_mutation -> - Misc.fatal_errorf "Jkind.equal: Performed unexpected mutation" - | Unequal -> false - | Equal_no_mutation | Equal_mutated_first | Equal_mutated_second -> true) + | Sort s1, Sort s2 -> + sort_equal_result ~allow_mutation (Sort.equate_tracking_mutation s1 s2) + | Product ts, Sort sort | Sort sort, Product ts -> ( + match to_product_sort ts with + | None -> false + | Some sort' -> + sort_equal_result ~allow_mutation + (Sort.equate_tracking_mutation sort sort')) + | Product ts1, Product ts2 -> + List.equal (equate_or_equal ~allow_mutation) ts1 ts2 | Any, Any -> true - | (Any | Sort _), _ -> false + | (Any | Sort _ | Product _), _ -> false - let sub t1 t2 : Misc.Le_result.t = + let rec sub t1 t2 : Misc.Le_result.t = match t1, t2 with | Any, Any -> Equal | _, Any -> Less | Any, _ -> Not_le | Sort s1, Sort s2 -> if Sort.equate s1 s2 then Equal else Not_le - - let intersection t1 t2 = + | Product ts1, Product ts2 -> + if List.compare_lengths ts1 ts2 = 0 + then Misc.Le_result.combine_list (List.map2 sub ts1 ts2) + else Not_le + | Product ts1, Sort s2 -> ( + match to_product_sort ts1 with + | None -> Not_le + | Some s1 -> if Sort.equate s1 s2 then Equal else Not_le) + | Sort s1, Product ts2 -> ( + match to_product_sort ts2 with + | None -> Not_le + | Some s2 -> if Sort.equate s1 s2 then Equal else Not_le) + + let rec intersection t1 t2 = match t1, t2 with | _, Any -> Some t1 | Any, _ -> Some t2 | Sort s1, Sort s2 -> if Sort.equate s1 s2 then Some t1 else None + | Product ts1, Product ts2 -> + if List.compare_lengths ts1 ts2 = 0 + then + let components = List.map2 intersection ts1 ts2 in + Option.map + (fun x -> Product x) + (Misc.Stdlib.List.some_if_all_elements_are_some components) + else None + | (Product ts as t), Sort sort | Sort sort, (Product ts as t) -> ( + match to_product_sort ts with + | None -> None + | Some sort' -> if Sort.equate sort sort' then Some t else None) let of_new_sort_var () = let sort = Sort.new_var () in Sort sort, sort - let format ppf = - let open Format in - function - | Any -> fprintf ppf "any" - | Sort s -> ( - match Sort.get s with - | Const s -> fprintf ppf "%a" Sort.Const.format s - | Var v -> fprintf ppf "%s" (Sort.Var.name v)) - - module Debug_printers = struct - open Format + let rec default_to_value_and_get : Layout.t -> Const.t = function + | Any -> Any + | Sort s -> Const.of_sort_const (Sort.default_to_value_and_get s) + | Product p -> Product (List.map default_to_value_and_get p) - let t ppf = function - | Any -> fprintf ppf "Any" - | Sort s -> fprintf ppf "Sort %a" Sort.Debug_printers.t s - end + let format ppf layout = + let open Format in + let rec pp_element ~nested ppf : Layout.t -> unit = function + | Any -> fprintf ppf "any" + | Sort s -> Sort.format ppf s + | Product ts -> + let pp_sep ppf () = Format.fprintf ppf " & " in + Misc.pp_nested_list ~nested ~pp_element ~pp_sep ppf ts + in + pp_element ~nested:false ppf layout end module Externality = Jkind_axis.Externality @@ -257,19 +372,19 @@ module Const = struct let value_or_null = { jkind = - of_layout (Sort Value) ~mode_crossing:false ~nullability:Maybe_null; + of_layout (Base Value) ~mode_crossing:false ~nullability:Maybe_null; name = "value_or_null" } let value = { jkind = - of_layout (Sort Value) ~mode_crossing:false ~nullability:Non_null; + of_layout (Base Value) ~mode_crossing:false ~nullability:Non_null; name = "value" } let immutable_data = { jkind = - { layout = Sort Value; + { layout = Base Value; modes_upper_bounds = { linearity = Linearity.Const.min; contention = Contention.Const.min; @@ -285,7 +400,7 @@ module Const = struct let mutable_data = { jkind = - { layout = Sort Value; + { layout = Base Value; modes_upper_bounds = { linearity = Linearity.Const.min; contention = Contention.Const.max; @@ -301,12 +416,12 @@ module Const = struct (* CR layouts v3: change to [or_null] when separability is implemented. *) let void = - { jkind = of_layout (Sort Void) ~mode_crossing:false ~nullability:Non_null; + { jkind = of_layout (Base Void) ~mode_crossing:false ~nullability:Non_null; name = "void" } let immediate = - { jkind = of_layout (Sort Value) ~mode_crossing:true ~nullability:Non_null; + { jkind = of_layout (Base Value) ~mode_crossing:true ~nullability:Non_null; name = "immediate" } @@ -350,7 +465,7 @@ module Const = struct (* CR layouts v3: change to [Maybe_null] when separability is implemented. *) let float64 = { jkind = - of_layout (Sort Float64) ~mode_crossing:true ~nullability:Non_null; + of_layout (Base Float64) ~mode_crossing:true ~nullability:Non_null; name = "float64" } @@ -359,27 +474,27 @@ module Const = struct (* CR layouts v3: change to [Maybe_null] when separability is implemented. *) let float32 = { jkind = - of_layout (Sort Float32) ~mode_crossing:true ~nullability:Non_null; + of_layout (Base Float32) ~mode_crossing:true ~nullability:Non_null; name = "float32" } (* CR layouts v3: change to [Maybe_null] when separability is implemented. *) let word = - { jkind = of_layout (Sort Word) ~mode_crossing:false ~nullability:Non_null; + { jkind = of_layout (Base Word) ~mode_crossing:false ~nullability:Non_null; name = "word" } (* CR layouts v3: change to [Maybe_null] when separability is implemented. *) let bits32 = { jkind = - of_layout (Sort Bits32) ~mode_crossing:false ~nullability:Non_null; + of_layout (Base Bits32) ~mode_crossing:false ~nullability:Non_null; name = "bits32" } (* CR layouts v3: change to [Maybe_null] when separability is implemented. *) let bits64 = { jkind = - of_layout (Sort Bits64) ~mode_crossing:false ~nullability:Non_null; + of_layout (Base Bits64) ~mode_crossing:false ~nullability:Non_null; name = "bits64" } @@ -579,6 +694,29 @@ module Const = struct | Immediate -> Builtin.immediate.jkind | Immediate64 -> Builtin.immediate64.jkind + let jkind_of_product_annotations jkinds = + let folder (layouts, mode_ub, ext_ub, null_ub) + { layout; + modes_upper_bounds; + externality_upper_bound; + nullability_upper_bound + } = + ( layout :: layouts, + Modes.join mode_ub modes_upper_bounds, + Externality.join ext_ub externality_upper_bound, + Nullability.join null_ub nullability_upper_bound ) + in + let layouts, mode_ub, ext_ub, null_ub = + List.fold_left folder + ([], Modes.min, Externality.min, Nullability.min) + jkinds + in + { layout = Product (List.rev layouts); + modes_upper_bounds = mode_ub; + externality_upper_bound = ext_ub; + nullability_upper_bound = null_ub + } + let rec of_user_written_annotation_unchecked_level (jkind : Jane_syntax.Jkind.t) : t = match jkind with @@ -625,6 +763,9 @@ module Const = struct Externality.meet base.externality_upper_bound (Option.value ~default:Externality.max parsed_modifiers.externality) } + | Product ts -> + let jkinds = List.map of_user_written_annotation_unchecked_level ts in + jkind_of_product_annotations jkinds | Default | With _ | Kind_of _ -> Misc.fatal_error "XXX unimplemented" (* The [annotation_context] parameter can be used to allow annotations / kinds @@ -636,10 +777,11 @@ module Const = struct let get_required_layouts_level (_context : History.annotation_context) (jkind : t) : Language_extension.maturity = match jkind.layout, jkind.nullability_upper_bound with - | (Sort (Float64 | Float32 | Word | Bits32 | Bits64) | Any), _ - | Sort Value, Non_null -> + | (Base (Float64 | Float32 | Word | Bits32 | Bits64) | Any), _ + | Base Value, Non_null -> Stable - | Sort Void, _ | Sort Value, Maybe_null -> Alpha + | Base Void, _ | Base Value, Maybe_null -> Alpha + | Product _, _ -> Beta let of_user_written_annotation ~context Location.{ loc; txt = annot } = let const = of_user_written_annotation_unchecked_level annot in @@ -653,24 +795,38 @@ end module Desc = struct type t = | Const of Const.t - | Var of Sort.var (* all modes will be [max] *) + | Var of Sort.var + | Product of t list let format ppf = - let open Format in - function - | Const c -> fprintf ppf "%a" Const.format c - | Var v -> fprintf ppf "%s" (Sort.Var.name v) + let rec pp_element ~nested ppf = + let open Format in + function + | Const c -> fprintf ppf "%a" Const.format c + | Var v -> fprintf ppf "%s" (Sort.Var.name v) + | Product ts -> + let pp_sep ppf () = Format.fprintf ppf "@ & " in + Misc.pp_nested_list ~nested ~pp_element ~pp_sep ppf ts + in + pp_element ~nested:false ppf (* considers sort variables < Any. Two sort variables are in a [sub] relationship only when they are equal. Never does mutation. - Pre-condition: no filled-in sort variables. *) - let sub d1 d2 : Misc.Le_result.t = + Pre-condition: no filled-in sort variables. product must contain a var. *) + let rec sub d1 d2 : Misc.Le_result.t = match d1, d2 with | Const c1, Const c2 -> Const.sub c1 c2 | Var _, Const c when Const.equal Const.max c -> Less | Var v1, Var v2 -> if v1 == v2 then Equal else Not_le - | Const _, Var _ | Var _, Const _ -> Not_le + | Product ds1, Product ds2 -> + if List.compare_lengths ds1 ds2 = 0 + then Misc.Le_result.combine_list (List.map2 sub ds1 ds2) + else Not_le + | Const _, Product _ | Product _, Const _ | Const _, Var _ | Var _, Const _ + -> + Not_le + | Var _, Product _ | Product _, Var _ -> Not_le end module Jkind_desc = struct @@ -797,13 +953,63 @@ module Jkind_desc = struct let immediate = of_const Const.Builtin.immediate.jkind end - (* Post-condition: If the result is [Var v], then [!v] is [None]. *) - let get - { layout; - modes_upper_bounds; - externality_upper_bound; - nullability_upper_bound - } : Desc.t = + let product jkinds = + (* CR layouts v7.1: Here we throw away the history of the component + jkinds. This is not great. We should, as part of a broader pass on error + messages around product kinds, zip them up into some kind of product + history. *) + let folder (layouts, mode_ub, ext_ub, null_ub) + { jkind = + { layout; + modes_upper_bounds; + externality_upper_bound; + nullability_upper_bound + }; + history = _; + has_warned = _ + } = + ( layout :: layouts, + Modes.join mode_ub modes_upper_bounds, + Externality.join ext_ub externality_upper_bound, + Nullability.join null_ub nullability_upper_bound ) + in + let layouts, mode_ub, ext_ub, null_ub = + List.fold_left folder + ([], Modes.min, Externality.min, Nullability.min) + jkinds + in + { layout = Product (List.rev layouts); + modes_upper_bounds = mode_ub; + externality_upper_bound = ext_ub; + nullability_upper_bound = null_ub + } + + (* Post-condition: If the result contains [Var v], then [!v] is [None]. *) + let rec get_sort modes_upper_bounds externality_upper_bound + nullability_upper_bound s : Desc.t = + match Sort.get s with + | Base b -> + Const + { layout = Base b; + modes_upper_bounds; + externality_upper_bound; + nullability_upper_bound + } + | Var v -> Var v + | Product sorts -> + Desc.Product + (List.map + (fun x -> + get_sort modes_upper_bounds externality_upper_bound + nullability_upper_bound x) + sorts) + + let rec get + ({ layout; + modes_upper_bounds; + externality_upper_bound; + nullability_upper_bound + } as k) : Desc.t = match layout with | Any -> Const @@ -812,16 +1018,11 @@ module Jkind_desc = struct externality_upper_bound; nullability_upper_bound } - | Sort s -> ( - match Sort.get s with - | Const s -> - Const - { layout = Sort s; - modes_upper_bounds; - externality_upper_bound; - nullability_upper_bound - } - | Var v -> Var v) + | Sort s -> + get_sort modes_upper_bounds externality_upper_bound + nullability_upper_bound s + | Product layouts -> + Product (List.map (fun layout -> get { k with layout }) layouts) module Debug_printers = struct open Format @@ -882,6 +1083,9 @@ module Builtin = struct let immediate ~why = fresh_jkind Jkind_desc.Builtin.immediate ~why:(Immediate_creation why) + + let product ~why ts = + fresh_jkind (Jkind_desc.product ts) ~why:(Product_creation why) end let add_mode_crossing t = @@ -997,7 +1201,7 @@ let for_boxed_variant ~all_voids = let for_arrow = fresh_jkind - { layout = Sort (Const Value); + { layout = Sort (Base Value); modes_upper_bounds = { linearity = Linearity.Const.max; areality = Locality.Const.max; @@ -1022,19 +1226,11 @@ let default_to_value_and_get }; _ } : Const.t = - match layout with - | Any -> - { layout = Any; - modes_upper_bounds; - externality_upper_bound; - nullability_upper_bound - } - | Sort s -> - { layout = Sort (Sort.default_to_value_and_get s); - modes_upper_bounds; - externality_upper_bound; - nullability_upper_bound - } + { layout = Layout.default_to_value_and_get layout; + modes_upper_bounds; + externality_upper_bound; + nullability_upper_bound + } let default_to_value t = ignore (default_to_value_and_get t) @@ -1042,17 +1238,25 @@ let get t = Jkind_desc.get t.jkind (* CR layouts: this function is suspect; it seems likely to reisenberg that refactoring could get rid of it *) -let sort_of_jkind l = - match get l with - | Const { layout = Sort s; _ } -> Sort.of_const s - | Const { layout = Any; _ } -> Misc.fatal_error "Jkind.sort_of_jkind" - | Var v -> Sort.of_var v +let sort_of_jkind (t : t) : sort = + let rec sort_of_layout (t : Layout.t) = + match t with + | Any -> Misc.fatal_error "Jkind.sort_of_jkind" + | Sort s -> s + | Product ls -> Sort.Product (List.map sort_of_layout ls) + in + sort_of_layout t.jkind.layout let get_layout jk : Layout.Const.t option = - match jk.jkind.layout with - | Any -> Some Any - | Sort s -> ( - match Sort.get s with Const s -> Some (Sort s) | Var _ -> None) + let rec aux : Layout.t -> Layout.Const.t option = function + | Any -> Some Any + | Sort s -> Layout.Const.of_sort s + | Product layouts -> + Option.map + (fun x -> Layout.Const.Product x) + (Misc.Stdlib.List.map_option aux layouts) + in + aux jk.jkind.layout let get_modal_upper_bounds jk = jk.jkind.modes_upper_bounds @@ -1065,9 +1269,15 @@ let set_externality_upper_bound jk externality_upper_bound = (* pretty printing *) let format ppf jkind = - match get jkind with - | Const c -> Format.fprintf ppf "%a" Const.format c - | Var v -> Format.fprintf ppf "%s" (Sort.Var.name v) + let rec pp_element ~nested ppf (d : Desc.t) = + match d with + | Const c -> Format.fprintf ppf "%a" Const.format c + | Var v -> Format.fprintf ppf "%s" (Sort.Var.name v) + | Product p -> + let pp_sep ppf () = Format.fprintf ppf "@ & " in + Misc.pp_nested_list ~nested ~pp_element ~pp_sep ppf p + in + pp_element ~nested:false ppf (get jkind) let printtyp_path = ref (fun _ _ -> assert false) @@ -1167,6 +1377,8 @@ module Format_history = struct | Statement -> fprintf ppf "it's the type of a statement" | Optional_arg_default -> fprintf ppf "it's the type of an optional argument default" + | Unboxed_tuple_element -> + fprintf ppf "it's the type of unboxed tuple element" | Layout_poly_in_external -> fprintf ppf "it's the layout polymorphic type in an external declaration@ \ @@ -1310,6 +1522,10 @@ module Format_history = struct "unknown @[(please alert the Jane Street@;\ compilers team with this message: %s)@]" s + let format_product_creation_reason ppf : History.product_creation_reason -> _ + = function + | Unboxed_tuple -> fprintf ppf "it is an unboxed tuple" + let format_creation_reason ppf ~layout_or_kind : History.creation_reason -> unit = function | Annotated (ctx, _) -> @@ -1324,6 +1540,7 @@ module Format_history = struct format_value_or_null_creation_reason ppf value | Value_creation value -> format_value_creation_reason ppf ~layout_or_kind value + | Product_creation product -> format_product_creation_reason ppf product | Concrete_creation concrete -> format_concrete_creation_reason ppf concrete | Concrete_legacy_creation concrete -> format_concrete_legacy_creation_reason ppf concrete @@ -1445,7 +1662,7 @@ module Violation = struct let subjkind_format verb k2 = match get k2 with | Var _ -> dprintf "%s representable" verb - | Const _ -> + | Const _ | Product _ -> dprintf "%s a sub%s of %a" verb layout_or_kind format_layout_or_kind k2 in let k1, k2, fmt_k1, fmt_k2, missing_cmi_option = @@ -1485,9 +1702,9 @@ module Violation = struct then let connective = match t.violation, get k2 with - | Not_a_subjkind _, Const _ -> + | Not_a_subjkind _, (Const _ | Product _) -> dprintf "be a sub%s of %a" layout_or_kind format_layout_or_kind k2 - | No_intersection _, Const _ -> + | No_intersection _, (Const _ | Product _) -> dprintf "overlap with %a" format_layout_or_kind k2 | _, Var _ -> dprintf "be representable" in @@ -1605,6 +1822,27 @@ let is_max jkind = sub Builtin.any_dummy_jkind jkind let has_layout_any jkind = match jkind.jkind.layout with Any -> true | _ -> false +let is_nary_product n t = + let components = + List.init n (fun _ -> Jkind_types.Layout.Sort (Sort.new_var ())) + in + let bound = + { Jkind_desc.max with layout = Jkind_types.Layout.Product components } + in + if Misc.Le_result.is_le (Jkind_desc.sub t.jkind bound) + then + (* CR layouts v7.1: The histories here are wrong (we are giving each + component the history of the whole product). They don't show up in + errors, so it's fine for now, but we'll probably need to fix this as + part of improving errors around products. A couple options: re-work the + relevant bits of [Ctype.type_jkind_sub] to just work on layouts, or + introduce product histories. *) + Some + (List.map + (fun l -> { t with jkind = { t.jkind with layout = l } }) + components) + else None + (*********************************) (* debugging *) @@ -1629,6 +1867,7 @@ module Debug_printers = struct | Statement -> fprintf ppf "Statement" | Optional_arg_default -> fprintf ppf "Optional_arg_default" | Layout_poly_in_external -> fprintf ppf "Layout_poly_in_external" + | Unboxed_tuple_element -> fprintf ppf "Unboxed_tuple_element" let concrete_legacy_creation_reason ppf : History.concrete_legacy_creation_reason -> unit = function @@ -1716,6 +1955,10 @@ module Debug_printers = struct | Let_rec_variable v -> fprintf ppf "Let_rec_variable %a" Ident.print v | Unknown s -> fprintf ppf "Unknown %s" s + let product_creation_reason ppf : History.product_creation_reason -> _ = + function + | Unboxed_tuple -> fprintf ppf "Unboxed_tuple" + let creation_reason ppf : History.creation_reason -> unit = function | Annotated (ctx, loc) -> fprintf ppf "Annotated (%a,%a)" annotation_context ctx Location.print_loc @@ -1730,6 +1973,8 @@ module Debug_printers = struct | Value_creation value -> fprintf ppf "Value_creation %a" value_creation_reason value | Void_creation _ -> . + | Product_creation product -> + fprintf ppf "Product_creation %a" product_creation_reason product | Concrete_creation concrete -> fprintf ppf "Concrete_creation %a" concrete_creation_reason concrete | Concrete_legacy_creation concrete -> diff --git a/ocaml/typing/jkind.mli b/ocaml/typing/jkind.mli index 7345dea964c..fde0c94c691 100644 --- a/ocaml/typing/jkind.mli +++ b/ocaml/typing/jkind.mli @@ -58,7 +58,7 @@ module Nullability : sig include module type of Jkind_axis.Nullability with type t := t end -module Sort : Jkind_intf.Sort with type const = Jkind_types.Sort.const +module Sort : Jkind_intf.Sort with type base = Jkind_types.Sort.base type sort = Sort.t @@ -242,6 +242,11 @@ module Builtin : sig (** We know for sure that values of types of this jkind are always immediate *) val immediate : why:History.immediate_creation_reason -> t + + (** This is the jkind of unboxed products. The layout will be the product of + the layouts of the input kinds, and the other components of the kind will + be the join relevant component of the inputs. *) + val product : why:History.product_creation_reason -> t list -> t end (** Take an existing [t] and add an ability to mode-cross along all the axes. *) @@ -342,6 +347,9 @@ module Desc : sig type t = | Const of Const.t | Var of Sort.var + | Product of t list + + val format : Format.formatter -> t -> unit end (** Extract the [const] from a [Jkind.t], looking through unified @@ -442,9 +450,15 @@ val sub_with_history : t -> t -> (t, Violation.t) result mutation. *) val is_max : t -> bool -(** Checks to see whether a jkind is has layout. Never does any mutation. *) +(** Checks to see whether a jkind has layout any. Never does any mutation. *) val has_layout_any : t -> bool +(** Checks whether a jkind's layout is an n-ary product, and returns the jkinds + of the components if so (with each component inheriting the non-layout kind + pieces from the original input kind). May update sort variables to make the + layout a product. *) +val is_nary_product : int -> t -> t list option + (*********************************) (* debugging *) diff --git a/ocaml/typing/jkind_axis.ml b/ocaml/typing/jkind_axis.ml index 12454da12c9..551c4ce7679 100644 --- a/ocaml/typing/jkind_axis.ml +++ b/ocaml/typing/jkind_axis.ml @@ -49,6 +49,14 @@ module Externality = struct | External64, (External64 | Internal) | Internal, External64 -> External64 | Internal, Internal -> Internal + let join t1 t2 = + match t1, t2 with + | Internal, (External | External64 | Internal) + | (External | External64), Internal -> + Internal + | External64, (External | External64) | External, External64 -> External64 + | External, External -> External + let print ppf = function | External -> Format.fprintf ppf "external_" | External64 -> Format.fprintf ppf "external64" @@ -84,6 +92,11 @@ module Nullability = struct | Non_null, (Non_null | Maybe_null) | Maybe_null, Non_null -> Non_null | Maybe_null, Maybe_null -> Maybe_null + let join n1 n2 = + match n1, n2 with + | Maybe_null, (Non_null | Maybe_null) | Non_null, Maybe_null -> Maybe_null + | Non_null, Non_null -> Non_null + let print ppf = function | Non_null -> Format.fprintf ppf "non_null" | Maybe_null -> Format.fprintf ppf "maybe_null" @@ -104,6 +117,8 @@ module type Axis_s = sig val meet : t -> t -> t + val join : t -> t -> t + val print : Format.formatter -> t -> unit end diff --git a/ocaml/typing/jkind_axis.mli b/ocaml/typing/jkind_axis.mli index 69c93547333..e0fabab0aa4 100644 --- a/ocaml/typing/jkind_axis.mli +++ b/ocaml/typing/jkind_axis.mli @@ -28,6 +28,8 @@ module type Axis_s = sig val meet : t -> t -> t + val join : t -> t -> t + val print : Format.formatter -> t -> unit end diff --git a/ocaml/typing/jkind_intf.ml b/ocaml/typing/jkind_intf.ml index 7d090f2ad95..299dfe0413f 100644 --- a/ocaml/typing/jkind_intf.ml +++ b/ocaml/typing/jkind_intf.ml @@ -21,7 +21,7 @@ module type Sort = sig type t (** These are the constant sorts -- fully determined and without variables *) - type const = + type base = | Void (** No run time representation at all *) | Value (** Standard ocaml value representation *) | Float64 (** Unboxed 64-bit floats *) @@ -34,7 +34,9 @@ module type Sort = sig type var module Const : sig - type t = const + type t = + | Base of base + | Product of t list val equal : t -> t -> bool @@ -70,6 +72,8 @@ module type Sort = sig (** Create a new sort variable that can be unified. *) val new_var : unit -> t + val of_base : base -> t + val of_const : Const.t -> t val of_var : Var.t -> t @@ -80,9 +84,6 @@ module type Sort = sig val format : Format.formatter -> t -> unit - (** Defaults any variables to value; leaves other sorts alone *) - val default_to_value : t -> unit - (** Checks whether this sort is [void], defaulting to [value] if a sort variable is unfilled. *) val is_void_defaulting : t -> bool @@ -168,6 +169,7 @@ module History = struct | Statement | Optional_arg_default | Layout_poly_in_external + | Unboxed_tuple_element (* For sort variables that are in the "legacy" position on the jkind lattice, defaulting exactly to [value]. *) @@ -261,6 +263,8 @@ module History = struct | Unification_var | Array_type_argument + type product_creation_reason = Unboxed_tuple + type creation_reason = | Annotated of annotation_context * Location.t | Missing_cmi of Path.t @@ -269,6 +273,7 @@ module History = struct | Immediate_creation of immediate_creation_reason | Void_creation of void_creation_reason | Any_creation of any_creation_reason + | Product_creation of product_creation_reason | Concrete_creation of concrete_creation_reason | Concrete_legacy_creation of concrete_legacy_creation_reason | Primitive of Ident.t diff --git a/ocaml/typing/jkind_types.ml b/ocaml/typing/jkind_types.ml index 3646b18f9f4..c80849aff26 100644 --- a/ocaml/typing/jkind_types.ml +++ b/ocaml/typing/jkind_types.ml @@ -13,7 +13,7 @@ (**************************************************************************) module Sort = struct - type const = + type base = | Void | Value | Float64 @@ -24,42 +24,93 @@ module Sort = struct type t = | Var of var - | Const of const + | Base of base + | Product of t list - and var = t option ref + and var = + { mutable contents : t option; + uid : int (* For debugging / printing only *) + } + + let equal_base b1 b2 = + match b1, b2 with + | Void, Void + | Value, Value + | Float64, Float64 + | Float32, Float32 + | Word, Word + | Bits32, Bits32 + | Bits64, Bits64 -> + true + | (Void | Value | Float64 | Float32 | Word | Bits32 | Bits64), _ -> false + + let to_string_base = function + | Value -> "value" + | Void -> "void" + | Float64 -> "float64" + | Float32 -> "float32" + | Word -> "word" + | Bits32 -> "bits32" + | Bits64 -> "bits64" module Const = struct - type t = const + type t = + | Base of base + | Product of t list - let equal c1 c2 = + let rec equal c1 c2 = match c1, c2 with - | Void, Void - | Value, Value - | Float64, Float64 - | Float32, Float32 - | Word, Word - | Bits32, Bits32 - | Bits64, Bits64 -> - true - | (Void | Value | Float64 | Float32 | Word | Bits32 | Bits64), _ -> false - - let to_string = function - | Value -> "value" - | Void -> "void" - | Float64 -> "float64" - | Float32 -> "float32" - | Word -> "word" - | Bits32 -> "bits32" - | Bits64 -> "bits64" - - let format ppf const = Format.fprintf ppf "%s" (to_string const) + | Base b1, Base b2 -> equal_base b1 b2 + | Product cs1, Product cs2 -> List.equal equal cs1 cs2 + | (Base _ | Product _), _ -> false + + let format ppf c = + let rec pp_element ~nested ppf = function + | Base b -> Format.fprintf ppf "%s" (to_string_base b) + | Product cs -> + let pp_sep ppf () = Format.fprintf ppf "@ & " in + Misc.pp_nested_list ~nested ~pp_element ~pp_sep ppf cs + in + pp_element ~nested:false ppf c module Debug_printers = struct - open Format - let t ppf c = + let rec pp_element ~nested ppf = function + | Base b -> + Format.fprintf ppf "%s" + (match b with + | Void -> "Void" + | Value -> "Value" + | Float64 -> "Float64" + | Float32 -> "Float32" + | Word -> "Word" + | Bits32 -> "Bits32" + | Bits64 -> "Bits64") + | Product cs -> + let pp_sep ppf () = Format.fprintf ppf "@ , " in + Format.fprintf ppf "Product [%a]" + (Misc.pp_nested_list ~nested ~pp_element ~pp_sep) + cs + in + pp_element ~nested:false ppf c + end + end + + module Var = struct + type t = var + + let name { uid; _ } = "'_representable_layout_" ^ Int.to_string uid + end + + (*** debug printing **) + module Debug_printers = struct + open Format + + let rec t ppf = function + | Var v -> fprintf ppf "Var %a" var v + | Base b -> fprintf ppf - (match c with + (match b with | Void -> "Void" | Value -> "Value" | Float64 -> "Float64" @@ -67,24 +118,17 @@ module Sort = struct | Word -> "Word" | Bits32 -> "Bits32" | Bits64 -> "Bits64") - end - end + | Product ts -> + fprintf ppf "Product [ %a ]" + (pp_print_list ~pp_sep:(fun ppf () -> pp_print_text ppf "; ") t) + ts - module Var = struct - type t = var + and opt_t ppf = function + | Some s -> fprintf ppf "Some %a" t s + | None -> fprintf ppf "None" - let name : var -> string = - let next_id = ref 1 in - let named = ref [] in - fun v -> - match List.assq_opt v !named with - | Some name -> name - | None -> - let id = !next_id in - let name = "'_representable_layout_" ^ Int.to_string id in - next_id := id + 1; - named := (v, name) :: !named; - name + and var ppf v = + fprintf ppf "{@[@ contents = %a;@ uid = %d@ @]}" opt_t v.contents v.uid end (* To record changes to sorts, for use with `Types.{snapshot, backtrack}` *) @@ -96,49 +140,123 @@ module Sort = struct let log_change change = !change_log change - let undo_change (v, t_op) = v := t_op + let undo_change (v, t_op) = v.contents <- t_op let set : var -> t option -> unit = fun v t_op -> - log_change (v, !v); - v := t_op + log_change (v, v.contents); + v.contents <- t_op + + module Static = struct + (* Statically allocated values of various consts and sorts to save + allocations in in the core hot path functions. [T] is also included in + the outer module to provide the core sorts. *) + + module T = struct + let void = Base Void + + let value = Base Value + + let float64 = Base Float64 + + let float32 = Base Float32 + + let word = Base Word + + let bits32 = Base Bits32 + + let bits64 = Base Bits64 + + let of_base = function + | Void -> void + | Value -> value + | Float64 -> float64 + | Float32 -> float32 + | Word -> word + | Bits32 -> bits32 + | Bits64 -> bits64 + + let rec of_const : Const.t -> t = function + | Base b -> of_base b + | Product cs -> Product (List.map of_const cs) + end + + module T_option = struct + let value = Some T.value + + let void = Some T.void + + let float64 = Some T.float64 + + let float32 = Some T.float32 + + let word = Some T.word - (* Memoize these values for of_const *) + let bits32 = Some T.bits32 - let void = Const Void + let bits64 = Some T.bits64 - let value = Const Value + let of_base = function + | Void -> void + | Value -> value + | Float64 -> float64 + | Float32 -> float32 + | Word -> word + | Bits32 -> bits32 + | Bits64 -> bits64 - let float64 = Const Float64 + let rec of_const : Const.t -> t option = function + | Base b -> of_base b + | Product cs -> + Option.map + (fun x -> Product x) + (Misc.Stdlib.List.map_option of_const cs) + end + + module Const = struct + open Const + + let value = Base Value - let float32 = Const Float32 + let void = Base Void - let word = Const Word + let float64 = Base Float64 - let bits32 = Const Bits32 + let float32 = Base Float32 - let bits64 = Const Bits64 + let word = Base Word - let some_value = Some (Const Value) + let bits32 = Base Bits32 - let of_const = function - | Void -> void - | Value -> value - | Float64 -> float64 - | Float32 -> float32 - | Word -> word - | Bits32 -> bits32 - | Bits64 -> bits64 + let bits64 = Base Bits64 + + let of_base : base -> Const.t = function + | Value -> value + | Void -> void + | Float64 -> float64 + | Float32 -> float32 + | Word -> word + | Bits32 -> bits32 + | Bits64 -> bits64 + end + end let of_var v = Var v - let new_var () = Var (ref None) + let last_var_uid = ref 0 + + let new_var () = + incr last_var_uid; + Var { contents = None; uid = !last_var_uid } (* Post-condition: If the result is a [Var v], then [!v] is [None]. *) let rec get : t -> t = function - | Const _ as t -> t + | Base _ as t -> t + | Product ts as t -> + let ts' = List.map get ts in + if List.for_all2 ( == ) ts ts' then t else Product ts' | Var r as t -> ( - match !r with + match r.contents with | None -> t | Some s -> let result = get s in @@ -146,44 +264,20 @@ module Sort = struct (* path compression *) result) - let memoized_value : t option = Some (Const Value) - - let memoized_void : t option = Some (Const Void) - - let memoized_float64 : t option = Some (Const Float64) - - let memoized_float32 : t option = Some (Const Float32) - - let memoized_word : t option = Some (Const Word) - - let memoized_bits32 : t option = Some (Const Bits32) - - let memoized_bits64 : t option = Some (Const Bits64) - - let[@inline] get_memoized = function - | Value -> memoized_value - | Void -> memoized_void - | Float64 -> memoized_float64 - | Float32 -> memoized_float32 - | Word -> memoized_word - | Bits32 -> memoized_bits32 - | Bits64 -> memoized_bits64 - - let rec default_to_value_and_get : t -> const = function - | Const c -> c + let rec default_to_value_and_get : t -> Const.t = function + | Base b -> Static.Const.of_base b + | Product ts -> Product (List.map default_to_value_and_get ts) | Var r -> ( - match !r with + match r.contents with | None -> - set r memoized_value; - Value + set r Static.T_option.value; + Static.Const.value | Some s -> let result = default_to_value_and_get s in - set r (get_memoized result); + set r (Static.T_option.of_const result); (* path compression *) result) - let default_to_value t = ignore (default_to_value_and_get t) - (***********************) (* equality *) @@ -191,97 +285,138 @@ module Sort = struct | Unequal | Equal_mutated_first | Equal_mutated_second + | Equal_mutated_both | Equal_no_mutation let swap_equate_result = function | Equal_mutated_first -> Equal_mutated_second | Equal_mutated_second -> Equal_mutated_first - | (Unequal | Equal_no_mutation) as r -> r + | (Unequal | Equal_no_mutation | Equal_mutated_both) as r -> r + + let[@inline] sorts_of_product s = + (* In the equate functions, it's useful to pass around lists of sorts inside + the product constructor they came from to avoid re-allocating it if we + end up wanting to store it in a variable. We could probably eliminate the + use of this by collapsing a bunch of the functions below into each other, + but that would be much less readable. *) + match s with + | Product sorts -> sorts + | Var _ | Base _ -> Misc.fatal_error "Jkind_types.sorts_of_product" + + let rec equate_sort_sort s1 s2 = + match s1 with + | Base b1 -> swap_equate_result (equate_sort_base s2 b1) + | Var v1 -> equate_var_sort v1 s2 + | Product _ -> swap_equate_result (equate_sort_product s2 s1) - let equal_const_const c1 c2 = - match c1, c2 with - | Void, Void - | Value, Value - | Float64, Float64 - | Float32, Float32 - | Word, Word - | Bits32, Bits32 - | Bits64, Bits64 -> - Equal_no_mutation - | (Void | Value | Float64 | Float32 | Word | Bits32 | Bits64), _ -> Unequal + and equate_sort_base s1 b2 = + match s1 with + | Base b1 -> if equal_base b1 b2 then Equal_no_mutation else Unequal + | Var v1 -> equate_var_base v1 b2 + | Product _ -> Unequal - let rec equate_var_const v1 c2 = - match !v1 with - | Some s1 -> equate_sort_const s1 c2 + and equate_var_base v1 b2 = + match v1.contents with + | Some s1 -> equate_sort_base s1 b2 | None -> - set v1 (Some (of_const c2)); + set v1 (Static.T_option.of_base b2); Equal_mutated_first - and equate_var v1 s2 = + and equate_var_sort v1 s2 = match s2 with - | Const c2 -> equate_var_const v1 c2 + | Base b2 -> equate_var_base v1 b2 | Var v2 -> equate_var_var v1 v2 + | Product _ -> equate_var_product v1 s2 and equate_var_var v1 v2 = if v1 == v2 then Equal_no_mutation else - match !v1, !v2 with - | Some s1, _ -> swap_equate_result (equate_var v2 s1) - | _, Some s2 -> equate_var v1 s2 + match v1.contents, v2.contents with + | Some s1, _ -> swap_equate_result (equate_var_sort v2 s1) + | _, Some s2 -> equate_var_sort v1 s2 | None, None -> set v1 (Some (of_var v2)); Equal_mutated_first - and equate_sort_const s1 c2 = - match s1 with - | Const c1 -> equal_const_const c1 c2 - | Var v1 -> equate_var_const v1 c2 + and equate_var_product v1 s2 = + match v1.contents with + | Some s1 -> equate_sort_product s1 s2 + | None -> + set v1 (Some s2); + Equal_mutated_first - let equate_tracking_mutation s1 s2 = + and equate_sort_product s1 s2 = match s1 with - | Const c1 -> swap_equate_result (equate_sort_const s2 c1) - | Var v1 -> equate_var v1 s2 - - (* Don't expose whether or not mutation happened; we just need that for [Jkind] *) + | Base _ -> Unequal + | Product sorts1 -> + let sorts2 = sorts_of_product s2 in + equate_sorts sorts1 sorts2 + | Var v1 -> equate_var_product v1 s2 + + and equate_sorts sorts1 sorts2 = + let rec go sorts1 sorts2 acc = + match sorts1, sorts2 with + | [], [] -> acc + | sort1 :: sorts1, sort2 :: sorts2 -> ( + match equate_sort_sort sort1 sort2, acc with + | Unequal, _ -> Unequal + | _, Unequal -> assert false + | Equal_no_mutation, acc | acc, Equal_no_mutation -> + go sorts1 sorts2 acc + | Equal_mutated_both, _ | _, Equal_mutated_both -> + go sorts1 sorts2 Equal_mutated_both + | Equal_mutated_first, Equal_mutated_first -> + go sorts1 sorts2 Equal_mutated_first + | Equal_mutated_second, Equal_mutated_second -> + go sorts1 sorts2 Equal_mutated_second + | Equal_mutated_first, Equal_mutated_second + | Equal_mutated_second, Equal_mutated_first -> + go sorts1 sorts2 Equal_mutated_both) + | _, _ -> assert false + in + if List.compare_lengths sorts1 sorts2 = 0 + then go sorts1 sorts2 Equal_no_mutation + else Unequal + + let equate_tracking_mutation = equate_sort_sort + + (* Don't expose whether or not mutation happened; we just need that for + [Jkind] *) let equate s1 s2 = match equate_tracking_mutation s1 s2 with | Unequal -> false - | Equal_mutated_first | Equal_mutated_second | Equal_no_mutation -> true + | Equal_mutated_first | Equal_mutated_second | Equal_no_mutation + | Equal_mutated_both -> + true - let rec is_void_defaulting = function - | Const Void -> true - | Var v -> ( - match !v with - (* CR layouts v5: this should probably default to void now *) - | None -> - set v some_value; - false - | Some s -> is_void_defaulting s) - | Const (Value | Float64 | Float32 | Word | Bits32 | Bits64) -> false + let is_void_defaulting t = + (* CR layouts v5: this should probably default to void now *) + match default_to_value_and_get t with + | Base Void -> true + | Base (Value | Float64 | Float32 | Word | Bits32 | Bits64) -> false + | Product _ -> false (*** pretty printing ***) - let to_string s = - match get s with Var v -> Var.name v | Const c -> Const.to_string c - - let format ppf t = Format.fprintf ppf "%s" (to_string t) - - (*** debug printing **) - - module Debug_printers = struct - open Format - - let rec t ppf = function - | Var v -> fprintf ppf "Var %a" var v - | Const c -> Const.Debug_printers.t ppf c - - and opt_t ppf = function - | Some s -> fprintf ppf "Some %a" t s - | None -> fprintf ppf "None" - - and var ppf v = fprintf ppf "{ contents = %a }" opt_t !v - end + let rec to_string s = + match get s with + | Base b -> to_string_base b + | Var v -> Var.name v + | Product ts -> String.concat " * " (List.map to_string ts) + + let format ppf t = + let rec pp_element ~nested ppf t = + match get t with + | Base b -> Format.fprintf ppf "%s" (to_string_base b) + | Var v -> Format.fprintf ppf "%s" (Var.name v) + | Product ts -> + let pp_sep ppf () = Format.fprintf ppf " & " in + Misc.pp_nested_list ~nested ~pp_element ~pp_sep ppf ts + in + pp_element ~nested:false ppf t + + include Static.T let for_function = value @@ -323,12 +458,16 @@ module Sort = struct end module Layout = struct - type 'sort layout = - | Sort of 'sort + type t = + | Sort of Sort.t + | Product of t list | Any module Const = struct - type t = Sort.const layout + type t = + | Any + | Base of Sort.base + | Product of t list module Legacy = struct type t = @@ -344,10 +483,9 @@ module Layout = struct | Word | Bits32 | Bits64 + | Product of t list end end - - type t = Sort.t layout end module Modes = Mode.Alloc.Const diff --git a/ocaml/typing/jkind_types.mli b/ocaml/typing/jkind_types.mli index 54534960cf1..2c8bde2d84e 100644 --- a/ocaml/typing/jkind_types.mli +++ b/ocaml/typing/jkind_types.mli @@ -45,7 +45,7 @@ module Sort : sig (* We need to expose these details for use in [Jkind] *) (* Comments in [Jkind_intf.ml] *) - type const = + type base = | Void | Value | Float64 @@ -54,14 +54,19 @@ module Sort : sig | Bits32 | Bits64 + val to_string_base : base -> string + + val equal_base : base -> base -> bool + type t = | Var of var - | Const of const + | Base of base + | Product of t list - and var = t option ref + and var include - Jkind_intf.Sort with type t := t and type var := var and type const := const + Jkind_intf.Sort with type t := t and type var := var and type base := base val set_change_log : (change -> unit) -> unit @@ -69,6 +74,7 @@ module Sort : sig | Unequal | Equal_mutated_first | Equal_mutated_second + | Equal_mutated_both | Equal_no_mutation val equate_tracking_mutation : t -> t -> equate_result @@ -79,12 +85,19 @@ module Sort : sig end module Layout : sig - type 'sort layout = - | Sort of 'sort + (** Note that products have two possible encodings: as [Product ...] or as + [Sort (Product ...]. This duplication is hard to eliminate because of the + possibility that a sort variable may be instantiated by a product sort. *) + type t = + | Sort of Sort.t + | Product of t list | Any module Const : sig - type t = Sort.const layout + type t = + | Any + | Base of Sort.base + | Product of t list module Legacy : sig type t = @@ -101,10 +114,9 @@ module Layout : sig | Word | Bits32 | Bits64 + | Product of t list end end - - type t = Sort.t layout end module Modes = Mode.Alloc.Const diff --git a/ocaml/typing/oprint.ml b/ocaml/typing/oprint.ml index 7a976afd8d8..cf45e2d6236 100644 --- a/ocaml/typing/oprint.ml +++ b/ocaml/typing/oprint.ml @@ -323,23 +323,35 @@ let pr_var = Pprintast.tyvar let ty_var ~non_gen ppf s = pr_var ppf (if non_gen then "_" ^ s else s) -let rec print_out_jkind_const ppf (ojkind : Outcometree.out_jkind_const) = - match ojkind with - | Ojkind_const_default -> fprintf ppf "_" - | Ojkind_const_abbreviation abbrev -> fprintf ppf "%s" abbrev - | Ojkind_const_mod (base, modes) -> - fprintf ppf "%a mod @[%a@]" print_out_jkind_const base - (pp_print_list - ~pp_sep:(fun ppf () -> fprintf ppf "@ ") - (fun ppf -> fprintf ppf "%s")) - modes - | Ojkind_const_with _ | Ojkind_const_kind_of _ -> - failwith "XXX unimplemented jkind syntax" +let print_out_jkind_const ppf ojkind = + let rec pp_element ~nested ppf (ojkind : Outcometree.out_jkind_const) = + match ojkind with + | Ojkind_const_default -> fprintf ppf "_" + | Ojkind_const_abbreviation abbrev -> fprintf ppf "%s" abbrev + | Ojkind_const_mod (base, modes) -> + fprintf ppf "%a mod @[%a@]" (pp_element ~nested) base + (pp_print_list + ~pp_sep:(fun ppf () -> fprintf ppf "@ ") + (fun ppf -> fprintf ppf "%s")) + modes + | Ojkind_const_product ts -> + let pp_sep ppf () = Format.fprintf ppf "@ & " in + Misc.pp_nested_list ~nested ~pp_element ~pp_sep ppf ts + | Ojkind_const_with _ | Ojkind_const_kind_of _ -> + failwith "XXX unimplemented jkind syntax" + in + pp_element ~nested:false ppf ojkind let print_out_jkind ppf ojkind = - match ojkind with - | Ojkind_var v -> fprintf ppf "%s" v - | Ojkind_const jkind -> print_out_jkind_const ppf jkind + let rec pp_element ~nested ppf ojkind = + match ojkind with + | Ojkind_var v -> fprintf ppf "%s" v + | Ojkind_const jkind -> print_out_jkind_const ppf jkind + | Ojkind_product ts -> + let pp_sep ppf () = Format.fprintf ppf "@ & " in + Misc.pp_nested_list ~nested ~pp_element ~pp_sep ppf ts + in + pp_element ~nested:false ppf ojkind let print_out_jkind_annot ppf = function | None -> () @@ -546,6 +558,15 @@ and print_out_type_3 ppf = print_out_type_0 ppf ty; pp_print_char ppf ')'; pp_close_box ppf () + | Otyp_unboxed_tuple tyl -> + pp_open_box ppf 1; + fprintf ppf "#("; + fprintf + ppf "@[<0>%a@]" + (print_labeled_typlist print_simple_out_type " *") + tyl; + pp_print_char ppf ')'; + pp_close_box ppf () | Otyp_abstract | Otyp_open | Otyp_sum _ | Otyp_manifest (_, _) -> () | Otyp_record lbls -> print_record_decl ppf lbls diff --git a/ocaml/typing/outcometree.mli b/ocaml/typing/outcometree.mli index fefee674be4..bc262cd808c 100644 --- a/ocaml/typing/outcometree.mli +++ b/ocaml/typing/outcometree.mli @@ -55,9 +55,9 @@ type out_value = | Oval_string of string * int * out_string (* string, size-to-print, kind *) | Oval_stuff of string | Oval_tuple of (string option * out_value) list + | Oval_unboxed_tuple of (string option * out_value) list | Oval_variant of string * out_value option - type out_modality_legacy = Ogf_global type out_modality_new = string @@ -108,10 +108,12 @@ type out_jkind_const = | Ojkind_const_mod of out_jkind_const * string list | Ojkind_const_with of out_jkind_const * out_type | Ojkind_const_kind_of of out_type + | Ojkind_const_product of out_jkind_const list and out_jkind = | Ojkind_const of out_jkind_const | Ojkind_var of string + | Ojkind_product of out_jkind list and out_type_param = { oparam_name : string; @@ -137,6 +139,7 @@ and out_type = | Otyp_stuff of string | Otyp_sum of out_constructor list | Otyp_tuple of (string option * out_type) list + | Otyp_unboxed_tuple of (string option * out_type) list | Otyp_var of bool * string | Otyp_variant of out_variant * bool * (string list) option | Otyp_poly of out_vars_jkinds * out_type diff --git a/ocaml/typing/parmatch.ml b/ocaml/typing/parmatch.ml index 964ac050a65..9c568a79372 100644 --- a/ocaml/typing/parmatch.ml +++ b/ocaml/typing/parmatch.ml @@ -177,6 +177,8 @@ let all_coherent column = | Const_string _), _ -> false end | Tuple l1, Tuple l2 -> l1 = l2 + | Unboxed_tuple l1, Unboxed_tuple l2 -> + List.equal (fun (lbl1, _) (lbl2, _) -> lbl1 = lbl2) l1 l2 | Record (lbl1 :: _), Record (lbl2 :: _) -> Array.length lbl1.lbl_all = Array.length lbl2.lbl_all | Array (am1, _, _), Array (am2, _, _) -> am1 = am2 @@ -185,7 +187,8 @@ let all_coherent column = | Record [], Record [] | Variant _, Variant _ | Lazy, Lazy -> true - | _, _ -> false + | ( Construct _ | Constant _ | Tuple _ | Unboxed_tuple _ | Record _ + | Array _ | Variant _ | Lazy ), _ -> false in match List.find @@ -342,6 +345,8 @@ module Compat const_compare c1 c2 = 0 | Tpat_tuple labeled_ps, Tpat_tuple labeled_qs -> tuple_compat labeled_ps labeled_qs + | Tpat_unboxed_tuple labeled_ps, Tpat_unboxed_tuple labeled_qs -> + unboxed_tuple_compat labeled_ps labeled_qs | Tpat_lazy p, Tpat_lazy q -> compat p q | Tpat_record (l1,_),Tpat_record (l2,_) -> let ps,qs = records_args l1 l2 in @@ -369,6 +374,13 @@ module Compat && compat p q && tuple_compat labeled_ps labeled_qs | _,_ -> false + and unboxed_tuple_compat labeled_ps labeled_qs = + match labeled_ps,labeled_qs with + | [], [] -> true + | (p_label, p, _)::labeled_ps, (q_label, q, _)::labeled_qs -> + Option.equal String.equal p_label q_label + && compat p q && unboxed_tuple_compat labeled_ps labeled_qs + | _,_ -> false end module SyntacticCompat = @@ -447,6 +459,7 @@ let simple_match_args discr head args = | Construct _ | Variant _ | Tuple _ + | Unboxed_tuple _ | Array _ | Lazy -> args | Record lbls -> extract_fields (record_arg discr) (List.combine lbls args) @@ -458,6 +471,7 @@ let simple_match_args discr head args = | Record lbls -> omega_list lbls | Array (_, _, len) -> Patterns.omegas len | Tuple lbls -> omega_list lbls + | Unboxed_tuple lbls -> omega_list lbls | Variant { has_arg = false } | Any | Constant _ -> [] @@ -545,6 +559,14 @@ let do_set_args ~erase_mutable q r = match q with (Tpat_tuple (List.map2 (fun (lbl, _) arg -> lbl, arg) omegas args)) q.pat_type q.pat_env::rest +| {pat_desc = Tpat_unboxed_tuple omegas} -> + let args,rest = + read_args (List.map (fun (_, pat, _) -> pat) omegas) r + in + make_pat + (Tpat_unboxed_tuple + (List.map2 (fun (lbl, _, sort) arg -> lbl, arg, sort) omegas args)) + q.pat_type q.pat_env::rest | {pat_desc = Tpat_record (omegas,closed)} -> let args,rest = read_args omegas r in make_pat @@ -841,6 +863,7 @@ let full_match closing env = match env with | Constant _ | Array _ -> false | Tuple _ + | Unboxed_tuple _ | Record _ | Lazy -> true @@ -857,7 +880,7 @@ let should_extend ext env = match ext with let path = get_constructor_type_path p.pat_type p.pat_env in Path.same path ext | Construct {cstr_tag=Extension _} -> false - | Constant _ | Tuple _ | Variant _ | Record _ + | Constant _ | Tuple _ | Unboxed_tuple _ | Variant _ | Record _ | Array _ | Lazy -> false | Any -> assert false end @@ -1142,6 +1165,8 @@ let rec has_instance p = match p.pat_desc with | Tpat_construct (_,_,ps, _) | Tpat_array (_, _, ps) -> has_instances ps | Tpat_tuple labeled_ps -> has_instances (List.map snd labeled_ps) + | Tpat_unboxed_tuple labeled_ps -> + has_instances (List.map (fun (_, p, _) -> p) labeled_ps) | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps) | Tpat_lazy p -> has_instance p @@ -1785,6 +1810,8 @@ let rec le_pat p q = | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false | Tpat_tuple(labeled_ps), Tpat_tuple(labeled_qs) -> le_tuple_pats labeled_ps labeled_qs + | Tpat_unboxed_tuple(labeled_ps), Tpat_unboxed_tuple(labeled_qs) -> + le_unboxed_tuple_pats labeled_ps labeled_qs | Tpat_lazy p, Tpat_lazy q -> le_pat p q | Tpat_record (l1,_), Tpat_record (l2,_) -> let ps,qs = records_args l1 l2 in @@ -1806,6 +1833,13 @@ and le_tuple_pats labeled_ps labeled_qs = && le_pat p q && le_tuple_pats labeled_ps labeled_qs | _, _ -> true +and le_unboxed_tuple_pats labeled_ps labeled_qs = + match labeled_ps, labeled_qs with + (p_label, p, _)::labeled_ps, (q_label, q, _)::labeled_qs -> + Option.equal String.equal p_label q_label + && le_pat p q && le_unboxed_tuple_pats labeled_ps labeled_qs + | _, _ -> true + let get_mins le ps = let rec select_rec r = function [] -> r @@ -1831,6 +1865,9 @@ let rec lub p q = match p.pat_desc,q.pat_desc with | Tpat_tuple ps, Tpat_tuple qs -> let rs = tuple_lubs ps qs in make_pat (Tpat_tuple rs) p.pat_type p.pat_env +| Tpat_unboxed_tuple ps, Tpat_unboxed_tuple qs -> + let rs = unboxed_tuple_lubs ps qs in + make_pat (Tpat_unboxed_tuple rs) p.pat_type p.pat_env | Tpat_lazy p, Tpat_lazy q -> let r = lub p q in make_pat (Tpat_lazy r) p.pat_type p.pat_env @@ -1888,6 +1925,13 @@ and tuple_lubs ps qs = match ps,qs with (p_label, lub p q) :: tuple_lubs ps qs | _,_ -> raise Empty +and unboxed_tuple_lubs ps qs = match ps,qs with +| [], [] -> [] +| (p_label, p, sort)::ps, (q_label, q, _)::qs + when Option.equal String.equal p_label q_label -> + (p_label, lub p q, sort) :: unboxed_tuple_lubs ps qs +| _,_ -> raise Empty + and lubs ps qs = match ps,qs with | p::ps, q::qs -> lub p q :: lubs ps qs | _,_ -> [] @@ -2032,6 +2076,8 @@ let rec collect_paths_from_pat r p = match p.pat_desc with | Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r | Tpat_tuple ps -> List.fold_left (fun r (_, p) -> collect_paths_from_pat r p) r ps +| Tpat_unboxed_tuple ps -> + List.fold_left (fun r (_, p, _) -> collect_paths_from_pat r p) r ps | Tpat_array (_, _, ps) | Tpat_construct (_, {cstr_tag=Extension _}, ps, _)-> List.fold_left collect_paths_from_pat r ps | Tpat_record (lps,_) -> @@ -2173,6 +2219,8 @@ let inactive ~partial pat = end | Tpat_tuple ps -> List.for_all (fun (_,p) -> loop p) ps + | Tpat_unboxed_tuple ps -> + List.for_all (fun (_,p,_) -> loop p) ps | Tpat_construct (_, _, ps, _) | Tpat_array (Immutable, _, ps) -> List.for_all (fun p -> loop p) ps | Tpat_alias (p,_,_,_,_) | Tpat_variant (_, Some p, _) -> diff --git a/ocaml/typing/patterns.ml b/ocaml/typing/patterns.ml index 1f5258f3879..1f988c2b832 100644 --- a/ocaml/typing/patterns.ml +++ b/ocaml/typing/patterns.ml @@ -53,6 +53,7 @@ module Simple = struct | `Any | `Constant of constant | `Tuple of (string option * pattern) list + | `Unboxed_tuple of (string option * pattern * Jkind.sort) list | `Construct of Longident.t loc * constructor_description * pattern list | `Variant of label * pattern option * row_desc ref @@ -95,6 +96,8 @@ module General = struct `Constant cst | Tpat_tuple ps -> `Tuple ps + | Tpat_unboxed_tuple ps -> + `Unboxed_tuple ps | Tpat_construct (cstr, cstr_descr, args, _) -> `Construct (cstr, cstr_descr, args) | Tpat_variant (cstr, arg, row_desc) -> @@ -114,6 +117,7 @@ module General = struct | `Alias (p, id, str, uid, mode) -> Tpat_alias (p, id, str, uid, mode) | `Constant cst -> Tpat_constant cst | `Tuple ps -> Tpat_tuple ps + | `Unboxed_tuple ps -> Tpat_unboxed_tuple ps | `Construct (cstr, cst_descr, args) -> Tpat_construct (cstr, cst_descr, args, None) | `Variant (cstr, arg, row_desc) -> @@ -142,6 +146,7 @@ module Head : sig | Construct of constructor_description | Constant of constant | Tuple of string option list + | Unboxed_tuple of (string option * Jkind.sort) list | Record of label_description list | Variant of { tag: label; has_arg: bool; @@ -167,6 +172,7 @@ end = struct | Construct of constructor_description | Constant of constant | Tuple of string option list + | Unboxed_tuple of (string option * Jkind.sort) list | Record of label_description list | Variant of { tag: label; has_arg: bool; @@ -185,6 +191,10 @@ end = struct | `Constant c -> Constant c, [] | `Tuple args -> Tuple (List.map fst args), (List.map snd args) + | `Unboxed_tuple args -> + let labels_and_sorts = List.map (fun (l, _, s) -> l, s) args in + let pats = List.map (fun (_, p, _) -> p) args in + Unboxed_tuple labels_and_sorts, pats | `Construct (_, c, args) -> Construct c, args | `Variant (tag, arg, cstr_row) -> @@ -217,6 +227,7 @@ end = struct | Constant _ -> 0 | Construct c -> c.cstr_arity | Tuple l -> List.length l + | Unboxed_tuple l -> List.length l | Array (_, _, n) -> n | Record l -> List.length l | Variant { has_arg; _ } -> if has_arg then 1 else 0 @@ -231,6 +242,9 @@ end = struct | Constant c -> Tpat_constant c | Tuple lbls -> Tpat_tuple (List.map (fun lbl -> lbl, omega) lbls) + | Unboxed_tuple lbls_and_sorts -> + Tpat_unboxed_tuple + (List.map (fun (lbl, sort) -> lbl, omega, sort) lbls_and_sorts) | Array (am, arg_sort, n) -> Tpat_array (am, arg_sort, omegas n) | Construct c -> let lid_loc = mkloc (Longident.Lident c.cstr_name) in diff --git a/ocaml/typing/patterns.mli b/ocaml/typing/patterns.mli index c0ef378bd2a..d50379464da 100644 --- a/ocaml/typing/patterns.mli +++ b/ocaml/typing/patterns.mli @@ -41,6 +41,7 @@ module Simple : sig | `Any | `Constant of constant | `Tuple of (string option * pattern) list + | `Unboxed_tuple of (string option * pattern * Jkind.sort) list | `Construct of Longident.t loc * constructor_description * pattern list | `Variant of label * pattern option * row_desc ref @@ -82,6 +83,7 @@ module Head : sig | Construct of constructor_description | Constant of constant | Tuple of string option list + | Unboxed_tuple of (string option * Jkind.sort) list | Record of label_description list | Variant of { tag: label; has_arg: bool; diff --git a/ocaml/typing/predef.ml b/ocaml/typing/predef.ml index 4d94b0afe35..18346cd57f2 100644 --- a/ocaml/typing/predef.ml +++ b/ocaml/typing/predef.ml @@ -289,8 +289,10 @@ let mk_add_extension add_extension id args jkinds = | Const const -> begin match Jkind.Const.get_layout const with - | Sort Value -> () - | Any | Sort (Void | Float32 | Float64 | Word | Bits32 | Bits64) -> + | Base Value -> () + | Any + | Base (Void | Float32 | Float64 | Word | Bits32 | Bits64) + | Product _ -> raise_error () end | _ -> raise_error ()) diff --git a/ocaml/typing/primitive.ml b/ocaml/typing/primitive.ml index dacb064d30a..8c06d784808 100644 --- a/ocaml/typing/primitive.ml +++ b/ocaml/typing/primitive.ml @@ -30,7 +30,7 @@ type boxed_vector = Pvec128 of vec128_type type native_repr = | Repr_poly - | Same_as_ocaml_repr of Jkind_types.Sort.const + | Same_as_ocaml_repr of Jkind_types.Sort.base | Unboxed_float of boxed_float | Unboxed_vector of boxed_vector | Unboxed_integer of boxed_integer @@ -383,7 +383,8 @@ let equal_native_repr nr1 nr2 = | Untagged_int | Unboxed_vector _ | Same_as_ocaml_repr _) | (Unboxed_float _ | Unboxed_integer _ | Untagged_int | Unboxed_vector _ | Same_as_ocaml_repr _), Repr_poly -> false - | Same_as_ocaml_repr s1, Same_as_ocaml_repr s2 -> Jkind_types.Sort.Const.equal s1 s2 + | Same_as_ocaml_repr s1, Same_as_ocaml_repr s2 -> + Jkind_types.Sort.equal_base s1 s2 | Same_as_ocaml_repr _, (Unboxed_float _ | Unboxed_integer _ | Untagged_int | Unboxed_vector _) -> false @@ -480,7 +481,7 @@ let prim_has_valid_reprs ~loc prim = let open Repr_check in let check = let stringlike_indexing_primitives = - let widths : (_ * _ * Jkind_types.Sort.const) list = + let widths : (_ * _ * Jkind_types.Sort.base) list = [ ("16", "", Value); ("32", "", Value); @@ -493,7 +494,7 @@ let prim_has_valid_reprs ~loc prim = ("64", "#", Bits64); ] in - let indices : (_ * Jkind_types.Sort.const) list = + let indices : (_ * Jkind_types.Sort.base) list = [ ("", Value); ("_indexed_by_nativeint#", Word); diff --git a/ocaml/typing/primitive.mli b/ocaml/typing/primitive.mli index 60f7c847f2d..3f8ab6bc64a 100644 --- a/ocaml/typing/primitive.mli +++ b/ocaml/typing/primitive.mli @@ -27,7 +27,7 @@ type boxed_vector = Pvec128 of vec128_type of a primitive *) type native_repr = | Repr_poly - | Same_as_ocaml_repr of Jkind_types.Sort.const + | Same_as_ocaml_repr of Jkind_types.Sort.base | Unboxed_float of boxed_float | Unboxed_vector of boxed_vector | Unboxed_integer of boxed_integer diff --git a/ocaml/typing/printpat.ml b/ocaml/typing/printpat.ml index 9bd8b25a6b5..8b7058af2fb 100644 --- a/ocaml/typing/printpat.ml +++ b/ocaml/typing/printpat.ml @@ -65,6 +65,8 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> | Tpat_constant c -> fprintf ppf "%s" (pretty_const c) | Tpat_tuple vs -> fprintf ppf "@[(%a)@]" (pretty_list pretty_labeled_val ",") vs + | Tpat_unboxed_tuple vs -> + fprintf ppf "@[#(%a)@]" (pretty_list pretty_labeled_val_sort ",") vs | Tpat_construct (_, cstr, [], _) -> fprintf ppf "%s" cstr.cstr_name | Tpat_construct (_, cstr, [w], None) -> @@ -157,6 +159,13 @@ and pretty_labeled_val ppf (l, p) = end; pretty_val ppf p +and pretty_labeled_val_sort ppf (l, p, _) = + begin match l with + | Some s -> fprintf ppf "~%s:" s + | None -> () + end; + pretty_val ppf p + and pretty_lvals ppf = function | [] -> () | [_,lbl,v] -> diff --git a/ocaml/typing/printtyp.ml b/ocaml/typing/printtyp.ml index 6df9305ca74..6a797adb888 100644 --- a/ocaml/typing/printtyp.ml +++ b/ocaml/typing/printtyp.ml @@ -644,6 +644,8 @@ and raw_type_desc ppf = function (if is_commu_ok c then "Cok" else "Cunknown") | Ttuple tl -> fprintf ppf "@[<1>Ttuple@,%a@]" labeled_type_list tl + | Tunboxed_tuple tl -> + fprintf ppf "@[<1>Tunboxed_tuple@,%a@]" labeled_type_list tl | Tconstr (p, tl, abbrev) -> fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p raw_type_list tl @@ -1261,6 +1263,8 @@ let out_jkind_of_user_jkind (jkind : Jane_syntax.Jkind.annotation) = List.map (fun {txt = (Parsetree.Mode s); _} -> s) modes in Ojkind_const_mod (base, modes) + | Product ts -> + Ojkind_const_product (List.map out_jkind_const_of_user_jkind ts) | With _ | Kind_of _ -> failwith "XXX unimplemented jkind syntax" in Ojkind_const (out_jkind_const_of_user_jkind jkind.txt) @@ -1271,21 +1275,25 @@ let out_jkind_of_const_jkind jkind = (* returns None for [value], according to (C2.1) from Note [When to print jkind annotations] *) let out_jkind_option_of_jkind jkind = - match Jkind.get jkind with - | Const jkind -> - let is_value = Jkind.Const.equal jkind Jkind.Const.Builtin.value.jkind + let rec desc_to_out_jkind : Jkind.Desc.t -> out_jkind = function + | Const jkind -> out_jkind_of_const_jkind jkind + | Var v -> Ojkind_var (Jkind.Sort.Var.name v) + | Product jkinds -> + Ojkind_product (List.map desc_to_out_jkind jkinds) + in + let desc = Jkind.get jkind in + let elide = + match desc with + | Const jkind -> (* C2.1 *) + Jkind.Const.equal jkind Jkind.Const.Builtin.value.jkind (* CR layouts v3.0: remove this hack once [or_null] is out of [Alpha]. *) || (not Language_extension.(is_at_least Layouts Alpha) && Jkind.Const.equal jkind Jkind.Const.Builtin.value_or_null.jkind) - in - begin match is_value with - | true -> None - | false -> Some (out_jkind_of_const_jkind jkind) - end - | Var v -> (* This handles (X1). *) - if !Clflags.verbose_types - then Some (Ojkind_var (Jkind.Sort.Var.name v)) - else None + | Var _ -> (* X1 *) + not !Clflags.verbose_types + | Product _ -> false + in + if elide then None else Some (desc_to_out_jkind desc) let alias_nongen_row mode px ty = match get_desc ty with @@ -1380,6 +1388,8 @@ let rec tree_of_typexp mode alloc_mode ty = Otyp_arrow (lab, tree_of_modes arg_mode, t1, rm, t2) | Ttuple labeled_tyl -> Otyp_tuple (tree_of_labeled_typlist mode labeled_tyl) + | Tunboxed_tuple labeled_tyl -> + Otyp_unboxed_tuple (tree_of_labeled_typlist mode labeled_tyl) | Tconstr(p, tyl, _abbrev) -> let p', s = best_type_path p in let tyl' = apply_subst s tyl in @@ -2661,11 +2671,13 @@ let trees_of_type_expansion' if var_jkinds then match get_desc ty with | Tvar { jkind; _ } | Tunivar { jkind; _ } -> - let olay = match Jkind.get jkind with + let rec okind_of_desc : Jkind.Desc.t -> _ = function | Const clay -> out_jkind_of_const_jkind clay | Var v -> Ojkind_var (Jkind.Sort.Var.name v) + | Product ds -> Ojkind_product (List.map okind_of_desc ds) in - Otyp_jkind_annot (out, olay) + let okind = okind_of_desc (Jkind.get jkind) in + Otyp_jkind_annot (out, okind) | _ -> out else diff --git a/ocaml/typing/printtyped.ml b/ocaml/typing/printtyped.ml index af2ae92e540..40fab8ae7c8 100644 --- a/ocaml/typing/printtyped.ml +++ b/ocaml/typing/printtyped.ml @@ -248,6 +248,9 @@ let rec core_type i ppf x = | Ttyp_tuple l -> line i ppf "Ttyp_tuple\n"; list i labeled_core_type ppf l; + | Ttyp_unboxed_tuple l -> + line i ppf "Ttyp_unboxed_tuple\n"; + list i labeled_core_type ppf l; | Ttyp_constr (li, _, l) -> line i ppf "Ttyp_constr %a\n" fmt_path li; list i core_type ppf l; @@ -315,6 +318,9 @@ and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x -> | Tpat_tuple (l) -> line i ppf "Tpat_tuple\n"; list i labeled_pattern ppf l; + | Tpat_unboxed_tuple (l) -> + line i ppf "Tpat_unboxed_tuple\n"; + list i labeled_pattern_with_sorts ppf l; | Tpat_construct (li, _, po, vto) -> line i ppf "Tpat_construct %a\n" fmt_longident li; list i pattern ppf po; @@ -353,6 +359,13 @@ and labeled_pattern : type k . _ -> _ -> string option * k general_pattern -> un tuple_component_label i ppf label; pattern i ppf x +and labeled_pattern_with_sorts : + type k . _ -> _ -> string option * k general_pattern * Jkind.sort -> unit = + fun i ppf (label, x, sort) -> + tuple_component_label i ppf label; + pattern i ppf x; + line i ppf "%a\n" Jkind.Sort.format sort + and pattern_extra i ppf (extra_pat, _, attrs) = match extra_pat with | Tpat_unpack -> @@ -476,6 +489,9 @@ and expression i ppf x = line i ppf "Texp_tuple\n"; alloc_mode i ppf am; list i labeled_expression ppf l; + | Texp_unboxed_tuple l -> + line i ppf "Texp_unboxed_tuple\n"; + list i labeled_sorted_expression ppf l; | Texp_construct (li, _, eo, am) -> line i ppf "Texp_construct %a\n" fmt_longident li; alloc_mode_option i ppf am; @@ -1159,6 +1175,12 @@ and labeled_expression i ppf (l, e) = tuple_component_label i ppf l; expression (i+1) ppf e; +and labeled_sorted_expression i ppf (l, e, s) = + line i ppf "\n"; + tuple_component_label i ppf l; + expression (i+1) ppf e; + line i ppf "%a\n" Jkind.Sort.format s; + and ident_x_expression_def i ppf (l, e) = line i ppf " \"%a\"\n" fmt_ident l; expression (i+1) ppf e; diff --git a/ocaml/typing/subst.ml b/ocaml/typing/subst.ml index e97d85fd7b1..7fb6097e50a 100644 --- a/ocaml/typing/subst.ml +++ b/ocaml/typing/subst.ml @@ -101,8 +101,7 @@ let with_additional_action = match config with | Duplicate_variables -> Duplicate_variables | Prepare_for_saving -> - let prepare_jkind loc jkind = - match Jkind.get jkind with + let rec prepare_desc loc : Jkind.Desc.t -> Jkind.t = function | Const const -> let builtin = List.find_opt (fun (builtin, _) -> Jkind.Const.equal const builtin) builtins @@ -112,6 +111,12 @@ let with_additional_action = | None -> Jkind.of_const const ~why:Jkind.History.Imported end | Var _ -> raise(Error (loc, Unconstrained_jkind_variable)) + | Product descs -> + Jkind.Builtin.product ~why:Unboxed_tuple + (List.map (prepare_desc loc) descs) + in + let prepare_jkind loc lay : Jkind.t = + prepare_desc loc (Jkind.get lay) in Prepare_for_saving prepare_jkind in diff --git a/ocaml/typing/tast_iterator.ml b/ocaml/typing/tast_iterator.ml index 9c210207cf8..373dea017e7 100644 --- a/ocaml/typing/tast_iterator.ml +++ b/ocaml/typing/tast_iterator.ml @@ -257,6 +257,7 @@ let pat | Tpat_var (_, s, _, _) -> iter_loc sub s | Tpat_constant _ -> () | Tpat_tuple l -> List.iter (fun (_, p) -> sub.pat sub p) l + | Tpat_unboxed_tuple l -> List.iter (fun (_, p, _) -> sub.pat sub p) l | Tpat_construct (lid, _, l, vto) -> iter_loc sub lid; List.iter (sub.pat sub) l; @@ -335,6 +336,7 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} = sub.expr sub exp; List.iter (sub.case sub) cases | Texp_tuple (list, _) -> List.iter (fun (_,e) -> sub.expr sub e) list + | Texp_unboxed_tuple list -> List.iter (fun (_,e,_) -> sub.expr sub e) list | Texp_construct (lid, _, args, _) -> iter_loc sub lid; List.iter (sub.expr sub) args @@ -629,6 +631,7 @@ let typ sub {ctyp_loc; ctyp_desc; ctyp_env; ctyp_attributes; _} = sub.typ sub ct1; sub.typ sub ct2 | Ttyp_tuple list -> List.iter (fun (_, t) -> sub.typ sub t) list + | Ttyp_unboxed_tuple list -> List.iter (fun (_, t) -> sub.typ sub t) list | Ttyp_constr (_, lid, list) -> iter_loc sub lid; List.iter (sub.typ sub) list diff --git a/ocaml/typing/tast_mapper.ml b/ocaml/typing/tast_mapper.ml index 9718f455e91..63d1535e9fe 100644 --- a/ocaml/typing/tast_mapper.ml +++ b/ocaml/typing/tast_mapper.ml @@ -301,6 +301,9 @@ let pat | Tpat_var (id, s, uid, m) -> Tpat_var (id, map_loc sub s, uid, m) | Tpat_tuple l -> Tpat_tuple (List.map (fun (label, p) -> label, sub.pat sub p) l) + | Tpat_unboxed_tuple l -> + Tpat_unboxed_tuple + (List.map (fun (label, p, sort) -> label, sub.pat sub p, sort) l) | Tpat_construct (loc, cd, l, vto) -> let vto = Option.map (fun (vl,cty) -> List.map (map_loc sub) vl, sub.typ sub cty) vto in @@ -466,6 +469,9 @@ let expr sub x = ) | Texp_tuple (list, am) -> Texp_tuple (List.map (fun (label, e) -> label, sub.expr sub e) list, am) + | Texp_unboxed_tuple list -> + Texp_unboxed_tuple + (List.map (fun (label, e, s) -> label, sub.expr sub e, s) list) | Texp_construct (lid, cd, args, am) -> Texp_construct (map_loc sub lid, cd, List.map (sub.expr sub) args, am) | Texp_variant (l, expo) -> @@ -879,6 +885,9 @@ let typ sub x = Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) | Ttyp_tuple list -> Ttyp_tuple (List.map (fun (label, t) -> label, sub.typ sub t) list) + | Ttyp_unboxed_tuple list -> + Ttyp_unboxed_tuple + (List.map (fun (label, t) -> label, sub.typ sub t) list) | Ttyp_constr (path, lid, list) -> Ttyp_constr (path, map_loc sub lid, List.map (sub.typ sub) list) | Ttyp_object (list, closed) -> diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index c35f6447d9c..10189d5ffdc 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -1296,6 +1296,10 @@ and build_as_type_aux ~refine ~mode (env : Env.t ref) p = let labeled_tyl = List.map (fun (label, p) -> label, build_as_type env p) pl in newty (Ttuple labeled_tyl), mode + | Tpat_unboxed_tuple pl -> + let labeled_tyl = + List.map (fun (label, p, _) -> label, build_as_type env p) pl in + newty (Tunboxed_tuple labeled_tyl), mode | Tpat_construct(_, cstr, pl, vto) -> let priv = (cstr.cstr_private = Private) in let mode = @@ -1452,6 +1456,8 @@ let reorder_pat loc env patl closed labeled_tl expected_ty = (* This assumes the [args] have already been reordered according to the [expected_ty], if needed. *) let solve_Ppat_tuple ~refine ~alloc_mode loc env args expected_ty = + (* CR layouts v5: consider sharing code with [solve_Ppat_unboxed_tuple] below + when we allow non-values in boxed tuples. *) let arity = List.length args in let arg_modes = match alloc_mode.tuple_modes with @@ -1474,6 +1480,37 @@ let solve_Ppat_tuple ~refine ~alloc_mode loc env args expected_ty = unify_pat_types ~refine loc env ty expected_ty; ann +(* This assumes the [args] have already been reordered according to the + [expected_ty], if needed. *) +let solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc env args expected_ty = + let arity = List.length args in + let arg_modes = + match alloc_mode.tuple_modes with + (* CR zqian: improve the modes of opened labeled tuple pattern. *) + | Some l when List.compare_length_with l arity = 0 -> l + | _ -> List.init arity (fun _ -> alloc_mode.mode) + in + let ann = + List.map2 + (fun (label, p) mode -> + let jkind, sort = + Jkind.of_new_sort_var ~why:Jkind.History.Unboxed_tuple_element + in + ( label, + p, + newgenvar jkind, + simple_pat_mode mode, + sort + )) + args arg_modes + in + let ty = + newgenty (Tunboxed_tuple (List.map (fun (lbl, _, t, _, _) -> lbl, t) ann)) + in + let expected_ty = generic_instance expected_ty in + unify_pat_types ~refine loc env ty expected_ty; + ann + let solve_constructor_annotation tps env name_list sty ty_args ty_ex = let expansion_scope = get_gadt_equations_level () in let ids = @@ -2320,15 +2357,19 @@ let rec has_literal_pattern p = | Ppat_tuple ps | Ppat_array ps -> List.exists has_literal_pattern ps + | Ppat_unboxed_tuple (ps, _) -> has_literal_pattern_labeled_tuple ps | Ppat_record (ps, _) -> List.exists (fun (_,p) -> has_literal_pattern p) ps | Ppat_or (p, q) -> has_literal_pattern p || has_literal_pattern q + and has_literal_pattern_jane_syntax : Jane_syntax.Pattern.t -> _ = function | Jpat_immutable_array (Iapat_immutable_array ps) -> List.exists has_literal_pattern ps | Jpat_layout (Lpat_constant _) -> true - | Jpat_tuple (labeled_ps, _) -> + | Jpat_tuple (labeled_ps, _) -> has_literal_pattern_labeled_tuple labeled_ps + +and has_literal_pattern_labeled_tuple labeled_ps = List.exists (fun (_, p) -> has_literal_pattern p) labeled_ps let check_scope_escape loc env level ty = @@ -2447,6 +2488,8 @@ and type_pat_aux pat_env = !env } in let type_tuple_pat spl closed = + (* CR layouts v5: consider sharing code with [type_unboxed_tuple_pat] below + when we allow non-values in boxed tuples. *) let args = match get_desc (expand_head !env expected_ty) with (* If it's a principally-known tuple pattern, try to reorder *) @@ -2473,6 +2516,38 @@ and type_pat_aux pat_attributes = sp.ppat_attributes; pat_env = !env } in + let type_unboxed_tuple_pat spl closed = + Jane_syntax_parsing.assert_extension_enabled ~loc Layouts + Language_extension.Beta; + let args = + match get_desc (expand_head !env expected_ty) with + (* If it's a principally-known tuple pattern, try to reorder *) + | Tunboxed_tuple labeled_tl when is_principal expected_ty -> + reorder_pat loc env spl closed labeled_tl expected_ty + (* If not, it's not allowed to be open (partial) *) + | _ -> + match closed with + | Open -> raise (Error (loc, !env, Partial_tuple_pattern_bad_type)) + | Closed -> spl + in + let spl_ann = + solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc env args expected_ty + in + let pl = + List.map (fun (lbl, p, t, alloc_mode, sort) -> + lbl, type_pat tps Value ~alloc_mode p t, sort) + spl_ann + in + let ty = + newty (Tunboxed_tuple (List.map (fun (lbl, p, _) -> lbl, p.pat_type) pl)) + in + rvp { + pat_desc = Tpat_unboxed_tuple pl; + pat_loc = loc; pat_extra=[]; + pat_type = ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env } + in match Jane_syntax.Pattern.of_ast sp with | Some (jpat, attrs) -> begin (* Normally this would go to an auxiliary function, but this function @@ -2579,6 +2654,8 @@ and type_pat_aux raise (Error (loc, !env, Invalid_interval)) | Ppat_tuple spl -> type_tuple_pat (List.map (fun sp -> None, sp) spl) Closed + | Ppat_unboxed_tuple (spl, oc) -> + type_unboxed_tuple_pat spl oc | Ppat_construct(lid, sarg) -> let expected_type = match extract_concrete_variant !env expected_ty with @@ -2987,6 +3064,7 @@ let rec pat_tuple_arity spat = | None -> match spat.ppat_desc with | Ppat_tuple args -> Local_tuple (List.length args) + | Ppat_unboxed_tuple (args,_c) -> Local_tuple (List.length args) | Ppat_any | Ppat_exception _ | Ppat_var _ -> Maybe_local_tuple | Ppat_constant _ | Ppat_interval _ | Ppat_construct _ | Ppat_variant _ @@ -3223,6 +3301,25 @@ let rec check_counter_example_pat mkp k (Tpat_tuple pl) ~pat_type:(newty (Ttuple (List.map (fun (l,p) -> (l,p.pat_type)) pl)))) + | Tpat_unboxed_tuple tpl -> + let tpl_ann = + solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc env + (List.map (fun (l,t,_) -> l, t) tpl) + expected_ty + in + List.iter2 + (fun (_, _, orig_sort) (_, _, _, _, sort) -> + (* Sanity check *) + assert (Jkind.Sort.equate orig_sort sort)) + tpl tpl_ann; + map_fold_cont + (fun (l,p,t,_,sort) k -> check_rec p t (fun p -> k (l, p, sort))) + tpl_ann + (fun pl -> + mkp k (Tpat_unboxed_tuple pl) + ~pat_type:(newty (Tunboxed_tuple + (List.map (fun (l,p,_) -> (l,p.pat_type)) + pl)))) | Tpat_construct(cstr_lid, constr, targs, _) -> if constr.cstr_generalized && must_backtrack_on_gadt then raise Need_backtrack; @@ -3808,6 +3905,8 @@ let rec is_nonexpansive exp = | Texp_probe {handler} -> is_nonexpansive handler | Texp_tuple (el, _) -> List.for_all (fun (_,e) -> is_nonexpansive e) el + | Texp_unboxed_tuple el -> + List.for_all (fun (_,e,_) -> is_nonexpansive e) el | Texp_construct(_, _, el, _) -> List.for_all is_nonexpansive el | Texp_variant(_, arg) -> is_nonexpansive_opt (Option.map fst arg) @@ -4328,6 +4427,7 @@ let check_partial_application ~statement exp = else begin match exp_desc with | Texp_ident _ | Texp_constant _ | Texp_tuple _ + | Texp_unboxed_tuple _ | Texp_construct _ | Texp_variant _ | Texp_record _ | Texp_field _ | Texp_setfield _ | Texp_array _ | Texp_list_comprehension _ | Texp_array_comprehension _ @@ -4413,10 +4513,12 @@ let contains_variant_either ty = try loop ty; unmark_type ty; false with Exit -> unmark_type ty; true +let shallow_iter_ppat_labeled_tuple f lst = List.iter (fun (_,p) -> f p) lst + let shallow_iter_ppat_jane_syntax f : Jane_syntax.Pattern.t -> _ = function | Jpat_immutable_array (Iapat_immutable_array pats) -> List.iter f pats | Jpat_layout (Lpat_constant _) -> () - | Jpat_tuple (lst, _) -> List.iter (fun (_,p) -> f p) lst + | Jpat_tuple (lst, _) -> shallow_iter_ppat_labeled_tuple f lst let shallow_iter_ppat f p = match Jane_syntax.Pattern.of_ast p with @@ -4431,6 +4533,7 @@ let shallow_iter_ppat f p = | Ppat_or (p1,p2) -> f p1; f p2 | Ppat_variant (_, arg) -> Option.iter f arg | Ppat_tuple lst -> List.iter f lst + | Ppat_unboxed_tuple (lst, _) -> shallow_iter_ppat_labeled_tuple f lst | Ppat_construct (_, Some (_, p)) | Ppat_exception p | Ppat_alias (p,_) | Ppat_open (_,p) @@ -5393,6 +5496,9 @@ and type_expect_ | Pexp_tuple sexpl -> type_tuple ~loc ~env ~expected_mode ~ty_expected ~explanation ~attributes:sexp.pexp_attributes (List.map (fun e -> None, e) sexpl) + | Pexp_unboxed_tuple sexpl -> + type_unboxed_tuple ~loc ~env ~expected_mode ~ty_expected ~explanation + ~attributes:sexp.pexp_attributes sexpl | Pexp_construct(lid, sarg) -> type_construct env expected_mode loc lid sarg ty_expected_explained sexp.pexp_attributes @@ -7630,6 +7736,8 @@ and type_application env app_loc expected_mode position_and_mode and type_tuple ~loc ~env ~(expected_mode : expected_mode) ~ty_expected ~explanation ~attributes sexpl = + (* CR layouts v5: consider sharing code with [type_unboxed_tuple] below when + we allow non-values in boxed tuples. *) let arity = List.length sexpl in assert (arity >= 2); let alloc_mode, argument_mode = register_allocation_value_mode expected_mode.mode in @@ -7652,7 +7760,15 @@ and type_tuple ~loc ~env ~(expected_mode : expected_mode) ~ty_expected | Some tuple_modes when List.compare_length_with tuple_modes arity = 0 -> List.map (fun mode -> Value.meet [mode; argument_mode]) tuple_modes - | _ -> + | Some tuple_modes -> + (* If the pattern and the expression have different tuple length, it + should be an type error. Here, we give the sound mode anyway. *) + let tuple_modes = + List.map (fun mode -> snd (register_allocation_value_mode mode)) tuple_modes + in + let argument_mode = Value.meet (argument_mode :: tuple_modes) in + List.init arity (fun _ -> argument_mode) + | None -> List.init arity (fun _ -> argument_mode) in let types_and_modes = List.combine labeled_subtypes argument_modes in @@ -7672,6 +7788,62 @@ and type_tuple ~loc ~env ~(expected_mode : expected_mode) ~ty_expected exp_attributes = attributes; exp_env = env } +and type_unboxed_tuple ~loc ~env ~(expected_mode : expected_mode) ~ty_expected + ~explanation ~attributes sexpl = + Jane_syntax_parsing.assert_extension_enabled ~loc Layouts + Language_extension.Beta; + let arity = List.length sexpl in + assert (arity >= 2); + let argument_mode = expected_mode.mode in + (* elements must be representable *) + let labels_types_and_sorts = + List.map (fun (label, _) -> + let jkind, sort = Jkind.of_new_sort_var ~why:Unboxed_tuple_element in + label, newgenvar jkind, sort) + sexpl + in + let labeled_subtypes = + List.map (fun (l, t, _) -> (l, t)) labels_types_and_sorts + in + let to_unify = newgenty (Tunboxed_tuple labeled_subtypes) in + with_explanation explanation (fun () -> + unify_exp_types loc env to_unify (generic_instance ty_expected)); + + let argument_modes = + match expected_mode.tuple_modes with + (* CR zqian: improve the modes of opened labeled tuple pattern. *) + | Some tuple_modes when List.compare_length_with tuple_modes arity = 0 -> + List.map (fun mode -> Value.meet [mode; argument_mode]) + tuple_modes + | Some tuple_modes -> + (* If the pattern and the expression have different tuple length, it + should be an type error. Here, we give the sound mode anyway. *) + let argument_mode = Value.meet (argument_mode :: tuple_modes) in + List.init arity (fun _ -> argument_mode) + | None -> + List.init arity (fun _ -> argument_mode) + in + let types_sorts_and_modes = + List.combine labels_types_and_sorts argument_modes + in + let expl = + List.map2 + (fun (label, body) ((_, ty, sort), argument_mode) -> + let argument_mode = mode_default argument_mode in + let argument_mode = expect_mode_cross env ty argument_mode in + (label, type_expect env argument_mode body (mk_expected ty), sort)) + sexpl types_sorts_and_modes + in + re { + exp_desc = Texp_unboxed_tuple expl; + exp_loc = loc; exp_extra = []; + (* Keep sharing *) + exp_type = + newty (Tunboxed_tuple + (List.map (fun (label, e, _) -> label, e.exp_type) expl)); + exp_attributes = attributes; + exp_env = env } + and type_construct env (expected_mode : expected_mode) loc lid sarg ty_expected_explained attrs = let { ty = ty_expected; explanation } = ty_expected_explained in diff --git a/ocaml/typing/typedecl.ml b/ocaml/typing/typedecl.ml index 0169b0abf7a..78be0970d98 100644 --- a/ocaml/typing/typedecl.ml +++ b/ocaml/typing/typedecl.ml @@ -99,6 +99,7 @@ type error = } | Null_arity_external | Missing_native_external + | Unboxed_product_in_external | Unbound_type_var of type_expr * type_declaration | Cannot_extend_private_type of Path.t | Not_extensible_type of Path.t @@ -125,7 +126,7 @@ type error = } | Jkind_empty_record | Non_value_in_sig of Jkind.Violation.t * string * type_expr - | Invalid_jkind_in_block of type_expr * Jkind.Sort.const * jkind_sort_loc + | Invalid_jkind_in_block of type_expr * Jkind.Sort.Const.t * jkind_sort_loc | Illegal_mixed_product of mixed_product_violation | Separability of Typedecl_separability.error | Bad_unboxed_attribute of string @@ -409,8 +410,9 @@ let check_representable ~why ~allow_unboxed env loc kloc typ = | Ok s -> begin if not allow_unboxed then match Jkind.Sort.default_to_value_and_get s with - | Void | Value -> () - | Float64 | Float32 | Word | Bits32 | Bits64 as const -> + | Base (Void | Value) -> () + | Base (Float64 | Float32 | Word | Bits32 | Bits64) + | Product _ as const -> raise (Error (loc, Invalid_jkind_in_block (typ, const, kloc))) end | Error err -> raise (Error (loc,Jkind_sort {kloc; typ; err})) @@ -1281,7 +1283,7 @@ module Element_repr = struct | Value_element | Element_without_runtime_component of { loc : Location.t; ty : type_expr } - let classify env loc ty jkind = + let classify env loc kloc ty jkind = if is_float env ty then Float_element else let const_jkind = Jkind.default_to_value_and_get jkind in @@ -1289,7 +1291,14 @@ module Element_repr = struct let externality_upper_bound = Jkind.Const.get_externality_upper_bound const_jkind in - match sort, externality_upper_bound with + let base = match sort with + | None -> + Misc.fatal_error "Element_repr.classify: unexpected abstract layout" + | Some (Product _ as c) -> + raise (Error (loc, Invalid_jkind_in_block (ty, c, kloc))) + | Some (Base b) -> b + in + match base, externality_upper_bound with (* CR layouts v5.1: We don't allow [External64] in the flat suffix of mixed blocks. That's because we haven't committed to whether the unboxing features of flambda2 can be used together with 32 bit @@ -1306,17 +1315,14 @@ module Element_repr = struct We may revisit this decision later when we know better whether we want flambda2 to unbox for 32 bit platforms. *) - | Some Value, (Internal | External64) -> - Value_element - | Some Value, External -> Imm_element - | Some Float64, _ -> Unboxed_element Float64 - | Some Float32, _ -> Unboxed_element Float32 - | Some Word, _ -> Unboxed_element Word - | Some Bits32, _ -> Unboxed_element Bits32 - | Some Bits64, _ -> Unboxed_element Bits64 - | Some Void, _ -> Element_without_runtime_component { loc; ty } - | None, _ -> - Misc.fatal_error "Element_repr.classify: unexpected abstract layout" + | Value, (Internal | External64) -> Value_element + | Value, External -> Imm_element + | Float64, _ -> Unboxed_element Float64 + | Float32, _ -> Unboxed_element Float32 + | Word, _ -> Unboxed_element Word + | Bits32, _ -> Unboxed_element Bits32 + | Bits64, _ -> Unboxed_element Bits64 + | Void, _ -> Element_without_runtime_component { loc; ty } let unboxed_to_flat : unboxed_element -> flat_element = function | Float64 -> Float64 @@ -1332,7 +1338,8 @@ module Element_repr = struct updating some assumptions in lambda, e.g. the translation of [value_prefix_len]. *) | Element_without_runtime_component { loc; ty } -> - raise (Error (loc, Invalid_jkind_in_block (ty, Void, Mixed_product))) + raise (Error (loc, Invalid_jkind_in_block (ty, Base Void, + Mixed_product))) | Float_element | Value_element -> None (* Compute the [flat_suffix] field of a mixed block record kind. *) @@ -1374,7 +1381,8 @@ module Element_repr = struct | None -> None | Some _ -> raise (Error (loc, - Invalid_jkind_in_block (ty, Void, Mixed_product))) + Invalid_jkind_in_block (ty, Base Void, + Mixed_product))) end in match find_flat_suffix ts with @@ -1402,7 +1410,8 @@ let update_constructor_representation | Cstr_tuple arg_types_and_modes -> let arg_reprs = List.map2 (fun {Types.ca_type=arg_type; _} arg_jkind -> - Element_repr.classify env loc arg_type arg_jkind, arg_type) + let kloc : jkind_sort_loc = Cstr_tuple { unboxed = false } in + Element_repr.classify env loc kloc arg_type arg_jkind, arg_type) arg_types_and_modes arg_jkinds in Element_repr.mixed_product_shape loc arg_reprs Cstr_tuple @@ -1417,7 +1426,9 @@ let update_constructor_representation | Cstr_record fields -> let arg_reprs = List.map (fun ld -> - Element_repr.classify env loc ld.Types.ld_type ld.ld_jkind, ld) + let kloc = Inlined_record { unboxed = false } in + Element_repr.classify env loc kloc ld.Types.ld_type ld.ld_jkind, + ld) fields in Element_repr.mixed_product_shape loc arg_reprs Cstr_record @@ -1480,7 +1491,9 @@ let update_decl_jkind env dpath decl = let reprs = List.mapi (fun i lbl -> - Element_repr.classify env loc lbl.Types.ld_type jkinds.(i), lbl) + let kloc = Record { unboxed = false } in + Element_repr.classify env loc kloc lbl.Types.ld_type jkinds.(i), + lbl) lbls in let repr_summary = @@ -1515,7 +1528,8 @@ let update_decl_jkind env dpath decl = | Unboxed_element Float64 -> Float64 | Element_without_runtime_component { ty; loc } -> raise (Error (loc, - Invalid_jkind_in_block (ty, Void, Mixed_product))) + Invalid_jkind_in_block (ty, Base Void, + Mixed_product))) | Unboxed_element _ | Imm_element | Value_element -> Misc.fatal_error "Expected only floats and float64s") reprs @@ -2719,7 +2733,7 @@ let type_sort_external ~is_layout_poly ~why env loc typ = in raise(Error (loc, Jkind_sort {kloc; typ; err})) -type sort_or_poly = Sort of Jkind.Sort.const | Poly +type sort_or_poly = Sort of Jkind.Sort.Const.t | Poly let make_native_repr env core_type ty ~global_repr ~is_layout_poly ~why = error_if_has_deep_native_repr_attributes core_type; @@ -2747,25 +2761,27 @@ let make_native_repr env core_type ty ~global_repr ~is_layout_poly ~why = sort_or_poly with | Native_repr_attr_absent, Poly -> Repr_poly - | Native_repr_attr_absent, Sort (Value as sort) -> - Same_as_ocaml_repr sort - | Native_repr_attr_absent, (Sort sort) -> + | Native_repr_attr_absent, Sort (Base Value) -> + Same_as_ocaml_repr Value + | Native_repr_attr_absent, (Sort (Base sort)) -> (if Language_extension.erasable_extensions_only () then (* Non-value sorts without [@unboxed] are not erasable. *) - let layout = Jkind_types.Sort.to_string (Const sort) in + let layout = Jkind_types.Sort.to_string (Base sort) in Location.prerr_warning core_type.ptyp_loc (Warnings.Incompatible_with_upstream (Warnings.Unboxed_attribute layout))); Same_as_ocaml_repr sort - | Native_repr_attr_present kind, (Poly | Sort Value) + | Native_repr_attr_absent, (Sort (Product _)) -> + raise (Error (core_type.ptyp_loc, Unboxed_product_in_external)) + | Native_repr_attr_present kind, (Poly | Sort (Base Value)) | Native_repr_attr_present (Untagged as kind), Sort _ -> begin match native_repr_of_type env kind ty with | None -> raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind)) | Some repr -> repr end - | Native_repr_attr_present Unboxed, (Sort sort) -> + | Native_repr_attr_present Unboxed, (Sort (Base sort)) -> (* We allow [@unboxed] on non-value sorts. This is to enable upstream-compatibility. We want the code to @@ -2790,11 +2806,13 @@ let make_native_repr env core_type ty ~global_repr ~is_layout_poly ~why = then (* There are additional requirements if we are operating in upstream compatible mode. *) - let layout = Jkind_types.Sort.to_string (Const sort) in + let layout = Jkind_types.Sort.to_string (Base sort) in Location.prerr_warning core_type.ptyp_loc (Warnings.Incompatible_with_upstream (Warnings.Non_value_sort layout))); Same_as_ocaml_repr sort + | Native_repr_attr_present Unboxed, (Sort (Product _)) -> + raise (Error (core_type.ptyp_loc, Unboxed_product_in_external)) let prim_const_mode m = match Mode.Locality.Guts.check_const m with @@ -2929,6 +2947,15 @@ let unexpected_layout_any_check prim env cty ty = [@layout_poly]. An exception is raised if any of these checks fails. *) +(* CR layouts v7.1: additionally, we do not allow externals to have unboxed + product args/returns. Right now this restriction is in place for all + externals, but we should be able to relax it for some primitives that are + implemented by the compiler, like %identity. Enforcement for [@layout_poly] + primitives is tricky, because it is legal to, e.g., apply such a primitive to + a sort variable, and that sort variable could subsequently be filled in by a + product. So we rule out some things here, but others must be caught much + later, in translprim. +*) let error_if_containing_unexpected_jkind prim env cty ty = Primitive.prim_has_valid_reprs ~loc:cty.ctyp_loc prim; unexpected_layout_any_check prim env cty ty @@ -3494,6 +3521,9 @@ let report_error ppf = function fprintf ppf "@[An external function with more than 5 arguments \ requires a second stub function@ \ for native-code compilation@]" + | Unboxed_product_in_external -> + fprintf ppf "@[Unboxed product layouts are not supported in external \ + declarations@]" | Unbound_type_var (ty, decl) -> fprintf ppf "@[A type variable is unbound in this type declaration"; begin match decl.type_kind, decl.type_manifest with diff --git a/ocaml/typing/typedecl.mli b/ocaml/typing/typedecl.mli index f79059edfe5..2eec7b6bc47 100644 --- a/ocaml/typing/typedecl.mli +++ b/ocaml/typing/typedecl.mli @@ -138,6 +138,7 @@ type error = } | Null_arity_external | Missing_native_external + | Unboxed_product_in_external | Unbound_type_var of type_expr * type_declaration | Cannot_extend_private_type of Path.t | Not_extensible_type of Path.t @@ -164,7 +165,7 @@ type error = } | Jkind_empty_record | Non_value_in_sig of Jkind.Violation.t * string * type_expr - | Invalid_jkind_in_block of type_expr * Jkind.Sort.const * jkind_sort_loc + | Invalid_jkind_in_block of type_expr * Jkind.Sort.Const.t * jkind_sort_loc | Illegal_mixed_product of mixed_product_violation | Separability of Typedecl_separability.error | Bad_unboxed_attribute of string diff --git a/ocaml/typing/typedecl_separability.ml b/ocaml/typing/typedecl_separability.ml index abea196661c..e76c182e654 100644 --- a/ocaml/typing/typedecl_separability.ml +++ b/ocaml/typing/typedecl_separability.ml @@ -131,6 +131,7 @@ let rec immediate_subtypes : type_expr -> type_expr list = fun ty -> | Tarrow(_,ty1,ty2,_) -> [ty1; ty2] | Ttuple(tys) -> List.map snd tys + | Tunboxed_tuple(tys) -> List.map snd tys | Tpackage(_, fl) -> (snd (List.split fl)) | Tobject(row,class_ty) -> let class_subtys = @@ -404,6 +405,7 @@ let check_type (* "Separable" case for constructors with known memory representation. *) | (Tarrow _ , Sep ) | (Ttuple _ , Sep ) + | (Tunboxed_tuple _ , Sep ) | (Tvariant(_) , Sep ) | (Tobject(_,_) , Sep ) | ((Tnil | Tfield _) , Sep ) @@ -411,6 +413,7 @@ let check_type (* "Deeply separable" case for these same constructors. *) | (Tarrow _ , Deepsep) | (Ttuple _ , Deepsep) + | (Tunboxed_tuple _ , Deepsep) | (Tvariant(_) , Deepsep) | (Tobject(_,_) , Deepsep) | ((Tnil | Tfield _) , Deepsep) diff --git a/ocaml/typing/typedecl_variance.ml b/ocaml/typing/typedecl_variance.ml index 6d4aeb6d71c..ab8bab40c14 100644 --- a/ocaml/typing/typedecl_variance.ml +++ b/ocaml/typing/typedecl_variance.ml @@ -66,6 +66,8 @@ let compute_variance env visited vari ty = compute_same ty2 | Ttuple tl -> List.iter (fun (_,t) -> compute_same t) tl + | Tunboxed_tuple tl -> + List.iter (fun (_,t) -> compute_same t) tl | Tconstr (path, tl, _) -> let open Variance in if tl = [] then () else begin diff --git a/ocaml/typing/typedtree.ml b/ocaml/typing/typedtree.ml index 27b52789c86..d6f52369550 100644 --- a/ocaml/typing/typedtree.ml +++ b/ocaml/typing/typedtree.ml @@ -93,6 +93,9 @@ and 'k pattern_desc = value general_pattern * Ident.t * string loc * Uid.t * Mode.Value.l -> value pattern_desc | Tpat_constant : constant -> value pattern_desc | Tpat_tuple : (string option * value general_pattern) list -> value pattern_desc + | Tpat_unboxed_tuple : + (string option * value general_pattern * Jkind.sort) list -> + value pattern_desc | Tpat_construct : Longident.t loc * constructor_description * value general_pattern list * (Ident.t loc list * core_type) option -> @@ -158,6 +161,7 @@ and expression_desc = | Texp_match of expression * Jkind.sort * computation case list * partial | Texp_try of expression * value case list | Texp_tuple of (string option * expression) list * alloc_mode + | Texp_unboxed_tuple of (string option * expression * Jkind.sort) list | Texp_construct of Longident.t loc * constructor_description * expression list * alloc_mode option | Texp_variant of label * (expression * alloc_mode) option @@ -617,6 +621,7 @@ and core_type_desc = | Ttyp_var of string option * Jkind.annotation option | Ttyp_arrow of arg_label * core_type * core_type | Ttyp_tuple of (string option * core_type) list + | Ttyp_unboxed_tuple of (string option * core_type) list | Ttyp_constr of Path.t * Longident.t loc * core_type list | Ttyp_object of object_field list * closed_flag | Ttyp_class of Path.t * Longident.t loc * core_type list @@ -858,6 +863,7 @@ let rec classify_pattern_desc : type k . k pattern_desc -> k pattern_category = function | Tpat_alias _ -> Value | Tpat_tuple _ -> Value + | Tpat_unboxed_tuple _ -> Value | Tpat_construct _ -> Value | Tpat_variant _ -> Value | Tpat_record _ -> Value @@ -888,6 +894,7 @@ let shallow_iter_pattern_desc = fun f -> function | Tpat_alias(p, _, _, _, _) -> f.f p | Tpat_tuple patl -> List.iter (fun (_, p) -> f.f p) patl + | Tpat_unboxed_tuple patl -> List.iter (fun (_, p, _) -> f.f p) patl | Tpat_construct(_, _, patl, _) -> List.iter f.f patl | Tpat_variant(_, pat, _) -> Option.iter f.f pat | Tpat_record (lbl_pat_list, _) -> @@ -910,6 +917,9 @@ let shallow_map_pattern_desc Tpat_alias (f.f p1, id, s, uid, m) | Tpat_tuple pats -> Tpat_tuple (List.map (fun (label, pat) -> label, f.f pat) pats) + | Tpat_unboxed_tuple pats -> + Tpat_unboxed_tuple + (List.map (fun (label, pat, sort) -> label, f.f pat, sort) pats) | Tpat_record (lpats, closed) -> Tpat_record (List.map (fun (lid, l,p) -> lid, l, f.f p) lpats, closed) | Tpat_construct (lid, c, pats, ty) -> @@ -1025,6 +1035,8 @@ let iter_pattern_full ~both_sides_of_or f sort pat = List.iter (fun (_, pat) -> loop f Jkind.Sort.value pat) patl (* CR layouts v5: tuple case to change when we allow non-values in tuples *) + | Tpat_unboxed_tuple patl -> + List.iter (fun (_, pat, sort) -> loop f sort pat) patl | Tpat_array (_, arg_sort, patl) -> List.iter (loop f arg_sort) patl | Tpat_lazy p | Tpat_exception p -> loop f Jkind.Sort.value p (* Cases without variables: *) @@ -1191,12 +1203,12 @@ let loc_of_decl ~uid = | Value vd -> vd.val_name | Value_binding vb -> let bound_idents = let_bound_idents_full [vb] in - let name = ListLabels.find_map + let name = ListLabels.find_map ~f:(fun (_, name, _, uid') -> if uid = uid' then Some name else None) bound_idents in (match name with | Some name -> name - | None -> + | None -> (* The find_map will only fail if a bad uid was given. In that case, just use the location of the pattern on the left of the binding. *) { txt = ""; loc = vb.vb_pat.pat_loc }) diff --git a/ocaml/typing/typedtree.mli b/ocaml/typing/typedtree.mli index ef881cdce85..373bd14791b 100644 --- a/ocaml/typing/typedtree.mli +++ b/ocaml/typing/typedtree.mli @@ -136,6 +136,15 @@ and 'k pattern_desc = (L1:P1, ... Ln:Pn) [(Some L1,P1); ...; (Some Ln,Pn)]) Any mix, e.g. (L1:P1, P2) [(Some L1,P1); ...; (None,P2)]) + Invariant: n >= 2 + *) + | Tpat_unboxed_tuple : + (string option * value general_pattern * Jkind.sort) list -> + value pattern_desc + (** #(P1, ..., Pn) [(None,P1,s1); ...; (None,Pn,sn)]) + #(L1:P1, ... Ln:Pn) [(Some L1,P1,s1); ...; (Some Ln,Pn,sn)]) + Any mix, e.g. #(L1:P1, P2) [(Some L1,P1,s1); ...; (None,P2,s2)]) + Invariant: n >= 2 *) | Tpat_construct : @@ -311,9 +320,21 @@ and expression_desc = (** try E with P1 -> E1 | ... | PN -> EN *) | Texp_tuple of (string option * expression) list * alloc_mode (** [Texp_tuple(el)] represents - - [(E1, ..., En)] when [el] is [(None, E1);...;(None, En)], - - [(L1:E1, ..., Ln:En)] when [el] is [(Some L1, E1);...;(Some Ln, En)], - - Any mix, e.g. [(L1: E1, E2)] when [el] is [(Some L1, E1); (None, E2)] + - [(E1, ..., En)] + when [el] is [(None, E1);...;(None, En)], + - [(L1:E1, ..., Ln:En)] + when [el] is [(Some L1, E1);...;(Some Ln, En)], + - Any mix, e.g. [(L1: E1, E2)] + when [el] is [(Some L1, E1); (None, E2)] + *) + | Texp_unboxed_tuple of (string option * expression * Jkind.sort) list + (** [Texp_unboxed_tuple(el)] represents + - [#(E1, ..., En)] + when [el] is [(None, E1, s1);...;(None, En, sn)], + - [#(L1:E1, ..., Ln:En)] + when [el] is [(Some L1, E1, s1);...;(Some Ln, En, sn)], + - Any mix, e.g. [#(L1: E1, E2)] + when [el] is [(Some L1, E1, s1); (None, E2, s2)] *) | Texp_construct of Longident.t loc * Types.constructor_description * @@ -866,6 +887,7 @@ and core_type_desc = | Ttyp_var of string option * Jkind.annotation option | Ttyp_arrow of arg_label * core_type * core_type | Ttyp_tuple of (string option * core_type) list + | Ttyp_unboxed_tuple of (string option * core_type) list | Ttyp_constr of Path.t * Longident.t loc * core_type list | Ttyp_object of object_field list * closed_flag | Ttyp_class of Path.t * Longident.t loc * core_type list diff --git a/ocaml/typing/typemod.ml b/ocaml/typing/typemod.ml index 7ecda17d0d6..a3857e40643 100644 --- a/ocaml/typing/typemod.ml +++ b/ocaml/typing/typemod.ml @@ -2912,8 +2912,9 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = if force_toplevel then (* See comment on [force_toplevel]. *) begin match Jkind.Sort.default_to_value_and_get sort with - | Value -> () - | Void | Float64 | Float32 | Word | Bits32 | Bits64 -> + | Base Value -> () + | Product _ + | Base (Void | Float64 | Float32 | Word | Bits32 | Bits64) -> raise (Error (sexpr.pexp_loc, env, Toplevel_unnamed_nonvalue sort)) end; Tstr_eval (expr, sort, attrs), [], shape_map, env @@ -2930,8 +2931,9 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = match vb.vb_pat.pat_desc with | Tpat_any -> begin match Jkind.Sort.default_to_value_and_get vb.vb_sort with - | Value -> () - | Void | Float64 | Float32 | Word | Bits32 | Bits64 -> + | Base Value -> () + | Product _ + | Base (Void | Float64 | Float32 | Word | Bits32 | Bits64) -> raise (Error (vb.vb_loc, env, Toplevel_unnamed_nonvalue vb.vb_sort)) end diff --git a/ocaml/typing/typeopt.ml b/ocaml/typing/typeopt.ml index 1fabff62eb8..741293fae9d 100644 --- a/ocaml/typing/typeopt.ml +++ b/ocaml/typing/typeopt.ml @@ -28,7 +28,8 @@ type error = | Non_value_sort_unknown_ty of Jkind.Sort.t | Small_number_sort_without_extension of Jkind.Sort.t * type_expr option | Not_a_sort of type_expr * Jkind.Violation.t - | Unsupported_sort of Jkind.Sort.const + | Unsupported_sort of Jkind.Sort.Const.t + | Unsupported_product_in_structure of Jkind.Sort.Const.t exception Error of Location.t * error @@ -125,7 +126,7 @@ type classification = let classify env loc ty sort : classification = let ty = scrape_ty env ty in match Jkind.(Sort.default_to_value_and_get sort) with - | Value -> begin + | Base Value -> begin if is_always_gc_ignorable env ty then Int else match get_desc ty with | Tvar _ | Tunivar _ -> @@ -156,16 +157,18 @@ let classify env loc ty sort : classification = end | Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil | Tvariant _ -> Addr - | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ -> + | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ | Tunboxed_tuple _ -> assert false end - | Float64 -> Unboxed_float Pfloat64 - | Float32 -> Unboxed_float Pfloat32 - | Bits32 -> Unboxed_int Pint32 - | Bits64 -> Unboxed_int Pint64 - | Word -> Unboxed_int Pnativeint - | Void -> - raise (Error (loc, Unsupported_sort Void)) + | Base Float64 -> Unboxed_float Pfloat64 + | Base Float32 -> Unboxed_float Pfloat32 + | Base Bits32 -> Unboxed_int Pint32 + | Base Bits64 -> Unboxed_int Pint64 + | Base Word -> Unboxed_int Pnativeint + | Base Void as c -> + raise (Error (loc, Unsupported_sort c)) + | Product _ as c -> + raise (Error (loc, Unsupported_product_in_structure c)) let array_type_kind ~elt_sort env loc ty = match scrape_poly env ty with @@ -253,11 +256,13 @@ let value_kind_of_value_jkind jkind = Jkind.Const.get_externality_upper_bound const_jkind in match layout, externality_upper_bound with - | Sort Value, External -> Pintval - | Sort Value, External64 -> + | Base Value, External -> Pintval + | Base Value, External64 -> if !Clflags.native_code && Sys.word_size = 64 then Pintval else Pgenval - | Sort Value, Internal -> Pgenval - | (Any | Sort (Void | Float64 | Float32 | Word | Bits32 | Bits64)) , _ -> + | Base Value, Internal -> Pgenval + | Any, _ + | Product _, _ + | Base (Void | Float64 | Float32 | Word | Bits32 | Bits64) , _ -> Misc.fatal_error "expected a layout of value" (* [value_kind] has a pre-condition that it is only called on values. With the @@ -694,21 +699,28 @@ let value_kind env loc ty = with | Missing_cmi_fallback -> raise (Error (loc, Non_value_layout (ty, None))) -let[@inline always] layout_of_const_sort_generic ~value_kind ~error - : Jkind.Sort.const -> _ = function - | Value -> Lambda.Pvalue (Lazy.force value_kind) - | Float64 when Language_extension.(is_at_least Layouts Stable) -> +let[@inline always] rec layout_of_const_sort_generic ~value_kind ~error + : Jkind.Sort.Const.t -> _ = function + | Base Value -> Lambda.Pvalue (Lazy.force value_kind) + | Base Float64 when Language_extension.(is_at_least Layouts Stable) -> Lambda.Punboxed_float Pfloat64 - | Word when Language_extension.(is_at_least Layouts Stable) -> + | Base Word when Language_extension.(is_at_least Layouts Stable) -> Lambda.Punboxed_int Pnativeint - | Bits32 when Language_extension.(is_at_least Layouts Stable) -> + | Base Bits32 when Language_extension.(is_at_least Layouts Stable) -> Lambda.Punboxed_int Pint32 - | Bits64 when Language_extension.(is_at_least Layouts Stable) -> + | Base Bits64 when Language_extension.(is_at_least Layouts Stable) -> Lambda.Punboxed_int Pint64 - | Float32 when Language_extension.(is_at_least Layouts Stable) && - Language_extension.(is_enabled Small_numbers) -> + | Base Float32 when Language_extension.(is_at_least Layouts Stable) && + Language_extension.(is_enabled Small_numbers) -> Lambda.Punboxed_float Pfloat32 - | (Void | Float64 | Float32 | Word | Bits32 | Bits64 as const) -> + | Product consts when Language_extension.(is_at_least Layouts Beta) -> + (* CR layouts v7.1: assess whether it is important for performance to support + deep value_kinds here *) + Lambda.Punboxed_product + (List.map (layout_of_const_sort_generic ~value_kind:(lazy Pgenval) ~error) + consts) + | (( Base (Void | Float32 | Float64 | Word | Bits32 | Bits64) + | Product _) as const) -> error const let layout env loc sort ty = @@ -716,28 +728,44 @@ let layout env loc sort ty = (Jkind.Sort.default_to_value_and_get sort) ~value_kind:(lazy (value_kind env loc ty)) ~error:(function - | Value -> assert false - | Void -> raise (Error (loc, Non_value_sort (Jkind.Sort.void,ty))) - | (Float32 as const) -> - raise (Error (loc, Small_number_sort_without_extension (Jkind.Sort.of_const const, Some ty))) - | (Float64 | Word | Bits32 | Bits64 as const) -> - raise (Error (loc, Sort_without_extension (Jkind.Sort.of_const const, Stable, Some ty)))) + | Base Value -> assert false + | Base Void -> + raise (Error (loc, Non_value_sort (Jkind.Sort.void,ty))) + | Base Float32 as const -> + raise (Error (loc, Small_number_sort_without_extension + (Jkind.Sort.of_const const, Some ty))) + | Base (Float64 | Word | Bits32 | Bits64) as const -> + raise (Error (loc, Sort_without_extension (Jkind.Sort.of_const const, + Stable, + Some ty))) + | Product _ as const -> + raise (Error (loc, Sort_without_extension (Jkind.Sort.of_const const, + Beta, + Some ty))) + ) let layout_of_sort loc sort = layout_of_const_sort_generic (Jkind.Sort.default_to_value_and_get sort) ~value_kind:(lazy Pgenval) ~error:(function - | Value -> assert false - | Void -> raise (Error (loc, Non_value_sort_unknown_ty Jkind.Sort.void)) - | (Float32 as const) -> - raise (Error (loc, Small_number_sort_without_extension (Jkind.Sort.of_const const, None))) - | (Float64 | Word | Bits32 | Bits64 as const) -> - raise (Error (loc, Sort_without_extension (Jkind.Sort.of_const const, Stable, None)))) - -let layout_of_const_sort s = + | Base Value -> assert false + | Base Void -> + raise (Error (loc, Non_value_sort_unknown_ty Jkind.Sort.void)) + | Base Float32 as const -> + raise (Error (loc, Small_number_sort_without_extension + (Jkind.Sort.of_const const, None))) + | Base (Float64 | Word | Bits32 | Bits64) as const -> + raise (Error (loc, Sort_without_extension + (Jkind.Sort.of_const const, Stable, None))) + | Product _ as const -> + raise (Error (loc, Sort_without_extension (Jkind.Sort.of_const const, + Beta, + None)))) + +let layout_of_base_sort b = layout_of_const_sort_generic - s + (Base b) ~value_kind:(lazy Pgenval) ~error:(fun const -> Misc.fatal_errorf "layout_of_const_sort: %a encountered" @@ -887,7 +915,13 @@ let report_error ppf = function (Jkind.Violation.report_with_offender ~offender:(fun ppf -> Printtyp.type_expr ppf ty)) err | Unsupported_sort const -> - fprintf ppf "Layout %a is not supported yet." Jkind.Sort.Const.format const + fprintf ppf "Layout %a is not supported yet." + Jkind.Sort.Const.format const + | Unsupported_product_in_structure const -> + fprintf ppf + "Product layout %a detected in structure in [Typeopt.Layout] \ + Please report this error to the Jane Street compilers team." + Jkind.Sort.Const.format const let () = Location.register_error_of_exn diff --git a/ocaml/typing/typeopt.mli b/ocaml/typing/typeopt.mli index b741ac7f813..7820d63c51f 100644 --- a/ocaml/typing/typeopt.mli +++ b/ocaml/typing/typeopt.mli @@ -52,9 +52,9 @@ val layout : gives a more precise result---this should only be used when the kind is needed for compilation but the precise Lambda.layout isn't needed for optimization. [layout_of_sort] gracefully errors on void, while - [layout_of_const_sort] loudly fails on void. *) + [layout_of_base] loudly fails on void. *) val layout_of_sort : Location.t -> Jkind.sort -> Lambda.layout -val layout_of_const_sort : Jkind.Sort.const -> Lambda.layout +val layout_of_base_sort : Jkind.Sort.base -> Lambda.layout (* Given a function type and the sort of its return type, compute the layout of its return type. *) diff --git a/ocaml/typing/types.ml b/ocaml/typing/types.ml index e39162eecda..1836a3ff33c 100644 --- a/ocaml/typing/types.ml +++ b/ocaml/typing/types.ml @@ -39,6 +39,7 @@ and type_desc = | Tvar of { name : string option; jkind : jkind } | Tarrow of arrow_desc * type_expr * type_expr * commutable | Ttuple of (string option * type_expr) list + | Tunboxed_tuple of (string option * type_expr) list | Tconstr of Path.t * type_expr list * abbrev_memo ref | Tobject of type_expr * (Path.t * type_expr list) option ref | Tfield of string * field_kind * type_expr * type_expr diff --git a/ocaml/typing/types.mli b/ocaml/typing/types.mli index 61c93e5f39b..0ba0e25e597 100644 --- a/ocaml/typing/types.mli +++ b/ocaml/typing/types.mli @@ -92,6 +92,16 @@ and type_desc = [Ttuple [Some "l1", t1; None, t2; Some "l3", t3]] ==> [l1:t1 * t2 * l3:t3] *) + | Tunboxed_tuple of (string option * type_expr) list + (** [Tunboxed_tuple [None, t1; ...; None, tn]] ==> [#(t1 * ... * tn)] + [Tunboxed_tuple [Some "l1", t1; ...; Some "ln", tn]] + ==> [#(l1:t1 * ... * ln:tn)] + + Any mix of labeled and unlabeled components also works: + [Tunboxed_tuple [Some "l1", t1; None, t2; Some "l3", t3]] + ==> [#(l1:t1 * t2 * l3:t3)] + *) + | Tconstr of Path.t * type_expr list * abbrev_memo ref (** [Tconstr (`A.B.t', [t1;...;tn], _)] ==> [(t1,...,tn) A.B.t] The last parameter keep tracks of known expansions, see [abbrev_memo]. *) diff --git a/ocaml/typing/typetexp.ml b/ocaml/typing/typetexp.ml index 900f913d515..cc1b42a15a1 100644 --- a/ocaml/typing/typetexp.ml +++ b/ocaml/typing/typetexp.ml @@ -714,6 +714,20 @@ and transl_type_aux env ~row_context ~aliased ~policy mode styp = (List.map (fun t -> (None, t)) stl) in ctyp desc typ + | Ptyp_unboxed_tuple stl -> + Jane_syntax_parsing.assert_extension_enabled ~loc Layouts + Language_extension.Beta; + let tl = + List.map + (fun (label, t) -> + label, transl_type env ~policy ~row_context Alloc.Const.legacy t) + stl + in + let ctyp_type = + newty (Tunboxed_tuple + (List.map (fun (label, ctyp) -> label, ctyp.ctyp_type) tl)) + in + ctyp (Ttyp_unboxed_tuple tl) ctyp_type | Ptyp_constr(lid, stl) -> let (path, decl) = Env.lookup_type ~loc:lid.loc lid.txt env in let stl = @@ -1468,7 +1482,8 @@ let report_error env ppf = function (Jkind.format_history ~intro:( dprintf "But it was inferred to have %t" (fun ppf -> match Jkind.get inferred_jkind with - | Const c -> fprintf ppf "kind %a" Jkind.Const.format c + | (Const _ | Product _) as d -> + fprintf ppf "kind %a" Jkind.Desc.format d | Var _ -> fprintf ppf "a representable kind"))) inferred_jkind | Multiple_constraints_on_type s -> diff --git a/ocaml/typing/uniqueness_analysis.ml b/ocaml/typing/uniqueness_analysis.ml index 5df9ac1853d..898209789be 100644 --- a/ocaml/typing/uniqueness_analysis.ml +++ b/ocaml/typing/uniqueness_analysis.ml @@ -1100,6 +1100,16 @@ and pattern_match_single pat paths : Ienv.Extension.t * UF.t = |> conjuncts_pattern_match in ext, UF.par uf_read uf_args + | Tpat_unboxed_tuple args -> + let ext, uf_args = + List.mapi + (fun i (_, arg, _) -> + let paths = Paths.tuple_field i paths in + pattern_match_single arg paths) + args + |> conjuncts_pattern_match + in + ext, uf_args let pattern_match pat = function | Match_tuple values -> pattern_match_tuple pat values @@ -1262,6 +1272,8 @@ let rec check_uniqueness_exp (ienv : Ienv.t) exp : UF.t = UF.seq uf_body uf_cases | Texp_tuple (es, _) -> UF.pars (List.map (fun (_, e) -> check_uniqueness_exp ienv e) es) + | Texp_unboxed_tuple es -> + UF.pars (List.map (fun (_, e, _) -> check_uniqueness_exp ienv e) es) | Texp_construct (_, _, es, _) -> UF.pars (List.map (fun e -> check_uniqueness_exp ienv e) es) | Texp_variant (_, None) -> UF.unused diff --git a/ocaml/typing/untypeast.ml b/ocaml/typing/untypeast.ml index 03c3993baba..76decbd6895 100644 --- a/ocaml/typing/untypeast.ml +++ b/ocaml/typing/untypeast.ml @@ -376,6 +376,10 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> Jane_syntax.Labeled_tuples.pat_of ~loc (List.map (fun (label, p) -> label, sub.pat sub p) list, Closed) |> add_jane_syntax_attributes + | Tpat_unboxed_tuple list -> + Ppat_unboxed_tuple + (List.map (fun (label, p, _) -> label, sub.pat sub p) list, + Closed) | Tpat_construct (lid, _, args, vto) -> let tyo = match vto with @@ -609,6 +613,9 @@ let expression sub exp = Jane_syntax.Labeled_tuples.expr_of ~loc (List.map (fun (lbl, e) -> lbl, sub.expr sub e) list) |> add_jane_syntax_attributes + | Texp_unboxed_tuple list -> + Pexp_unboxed_tuple + (List.map (fun (lbl, e, _) -> lbl, sub.expr sub e) list) | Texp_construct (lid, _, args, _) -> Pexp_construct (map_loc sub lid, (match args with @@ -1033,6 +1040,9 @@ let core_type sub ct = Jane_syntax.Labeled_tuples.typ_of ~loc (List.map (fun (lbl, t) -> lbl, sub.typ sub t) list) |> add_jane_syntax_attributes + | Ttyp_unboxed_tuple list -> + Ptyp_unboxed_tuple + (List.map (fun (lbl, t) -> lbl, sub.typ sub t) list) | Ttyp_constr (_path, lid, list) -> Ptyp_constr (map_loc sub lid, List.map (sub.typ sub) list) diff --git a/ocaml/typing/value_rec_check.ml b/ocaml/typing/value_rec_check.ml index 0881fa328f2..2caab87a453 100644 --- a/ocaml/typing/value_rec_check.ml +++ b/ocaml/typing/value_rec_check.ml @@ -186,6 +186,9 @@ let classify_expression : Typedtree.expression -> sd = | Texp_src_pos -> Static + | Texp_unboxed_tuple _ -> + Dynamic + | Texp_for _ | Texp_setfield _ | Texp_while _ @@ -681,6 +684,8 @@ let rec expression : Typedtree.expression -> term_judg = join [expression e; list arg args] << app_mode | Texp_tuple (exprs, _) -> list expression (List.map snd exprs) << Guard + | Texp_unboxed_tuple exprs -> + list expression (List.map (fun (_, e, _) -> e) exprs) << Return | Texp_array (_, elt_sort, exprs, _) -> list expression exprs << array_mode exp elt_sort | Texp_list_comprehension { comp_body; comp_clauses } -> @@ -1390,6 +1395,7 @@ and is_destructuring_pattern : type k . k general_pattern -> bool = | Tpat_alias (pat, _, _, _, _) -> is_destructuring_pattern pat | Tpat_constant _ -> true | Tpat_tuple _ -> true + | Tpat_unboxed_tuple _ -> true | Tpat_construct _ -> true | Tpat_variant _ -> true | Tpat_record (_, _) -> true diff --git a/ocaml/utils/misc.ml b/ocaml/utils/misc.ml index c144425cb46..f3c75d7af9e 100644 --- a/ocaml/utils/misc.ml +++ b/ocaml/utils/misc.ml @@ -149,6 +149,17 @@ module Stdlib = struct in aux [] l + let map_option f l = + let rec aux l acc = + match l with + | [] -> Some (List.rev acc) + | x :: xs -> + match f x with + | None -> None + | Some x -> aux xs (x :: acc) + in + aux l [] + let split_at n l = let rec aux n acc l = if n = 0 @@ -215,6 +226,14 @@ module Stdlib = struct } in find_prefix ~longest_common_prefix_rev:[] first second + + let rec iter_until_error ~f l = + match l with + | [] -> Ok () + | x :: xs -> + match f x with + | Ok () -> iter_until_error ~f xs + | Error _ as e -> e end module Option = struct @@ -1041,6 +1060,18 @@ let pp_two_columns ?(sep = "|") ?max_lines ppf (lines: (string * string) list) = ) lines; Format.fprintf ppf "@]" +let pp_parens_if condition printer ppf arg = + Format.fprintf ppf "%s%a%s" + (if condition then "(" else "") + printer arg + (if condition then ")" else "") + +let pp_nested_list ~nested ~pp_element ~pp_sep ppf arg = + Format.fprintf ppf "@[%a@]" + (pp_parens_if nested + (Format.pp_print_list ~pp_sep (pp_element ~nested:true))) + arg + (* showing configuration and configuration variables *) let show_config_and_exit () = Config.print_config stdout; diff --git a/ocaml/utils/misc.mli b/ocaml/utils/misc.mli index 5b64cd81ea1..203c0236df8 100644 --- a/ocaml/utils/misc.mli +++ b/ocaml/utils/misc.mli @@ -129,6 +129,10 @@ module Stdlib : sig is returned with the [xs] being the contents of those [Some]s, with order preserved. Otherwise return [None]. *) + val map_option : ('a -> 'b option) -> 'a t -> 'b t option + (** [map_option f l] is [some_if_all_elements_are_some (map f l)], but with + short circuiting. *) + val map2_prefix : ('a -> 'b -> 'c) -> 'a t -> 'b t -> ('c t * 'b t) (** [let r1, r2 = map2_prefix f l1 l2] If [l1] is of length n and [l2 = h2 @ t2] with h2 of length n, @@ -175,6 +179,13 @@ module Stdlib : sig (** Returns the longest list that, with respect to the provided equality function, is a prefix of both of the given lists. The input lists, each with such longest common prefix removed, are also returned. *) + + val iter_until_error + : f:('a -> (unit, 'b) Result.t) + -> 'a list + -> (unit, 'b) Result.t + (** [iter_until_error f l] applies [f] to each element of [l], in order, + short-circuiting in the case [f] returns [Error] on any element. *) end (** {2 Extensions to the Option module} *) @@ -627,6 +638,19 @@ val pp_two_columns : v} *) +val pp_nested_list : + nested:bool + -> pp_element:(nested:bool -> Format.formatter -> 'a -> unit) + -> pp_sep:(Format.formatter -> unit -> unit) + -> Format.formatter + -> 'a list + -> unit +(** [pp_nested_list ~nested ~pp_element ~pp_sep ppf args] prints the list [args] + with [pp_element] on [ppf]. The elements are separated by [pp_sep]. If + [~nested] is true, the list is wrapped in parens. The element printer is + always called with [nested:true], indicating that any inner lists are nested + and need parens. *) + val print_see_manual : Format.formatter -> int list -> unit (** See manual section *) diff --git a/printer/printast_with_mappings.ml b/printer/printast_with_mappings.ml index 2a1d3bc9032..42488f6942d 100644 --- a/printer/printast_with_mappings.ml +++ b/printer/printast_with_mappings.ml @@ -169,6 +169,10 @@ let include_kind i ppf = function | Structure -> line i ppf "Structure\n" | Functor -> line i ppf "Functor\n" +let labeled_tuple_element f i ppf (l, ct) = + option i string ppf l; + f i ppf ct + let rec core_type i ppf x = with_location_mapping ~loc:x.ptyp_loc ppf (fun () -> line i ppf "core_type %a\n" fmt_location x.ptyp_loc; @@ -187,6 +191,9 @@ let rec core_type i ppf x = | Ptyp_tuple l -> line i ppf "Ptyp_tuple\n"; list i core_type ppf l; + | Ptyp_unboxed_tuple l -> + line i ppf "Ptyp_unboxed_tuple\n"; + list i (labeled_tuple_element core_type) ppf l; | Ptyp_constr (li, l) -> line i ppf "Ptyp_constr %a\n" fmt_longident_loc li; list i core_type ppf l; @@ -249,6 +256,9 @@ and pattern i ppf x = | Ppat_tuple (l) -> line i ppf "Ppat_tuple\n"; list i pattern ppf l; + | Ppat_unboxed_tuple (l, c) -> + line i ppf "Ppat_unboxed_tuple %a\n" fmt_closed_flag c; + list i (labeled_tuple_element pattern) ppf l; | Ppat_construct (li, po) -> line i ppf "Ppat_construct %a\n" fmt_longident_loc li; option i @@ -325,6 +335,9 @@ and expression i ppf x = | Pexp_tuple (l) -> line i ppf "Pexp_tuple\n"; list i expression ppf l; + | Pexp_unboxed_tuple (l) -> + line i ppf "Pexp_unboxed_tuple\n"; + list i (labeled_tuple_element expression) ppf l; | Pexp_construct (li, eo) -> line i ppf "Pexp_construct %a\n" fmt_longident_loc li; option i expression ppf eo; @@ -448,6 +461,9 @@ and jkind_annotation i ppf (jkind : jkind_annotation) = | Kind_of type_ -> line i ppf "Kind_of\n"; core_type (i+1) ppf type_ + | Product jkinds -> + line i ppf "Product\n"; + list i jkind_annotation ppf jkinds and function_param i ppf { pparam_desc = desc; pparam_loc = loc } = match desc with From 163a5fc011f4a2edeba20f625a378ea55a74c268 Mon Sep 17 00:00:00 2001 From: dkalinichenko-js <118547217+dkalinichenko-js@users.noreply.github.com> Date: Fri, 6 Sep 2024 04:48:11 -0400 Subject: [PATCH 17/76] Mark `Capsule.Mutex.t` as crossing portability and contention (#3015) --- ocaml/otherlibs/stdlib_alpha/capsule.ml | 7 +++++-- ocaml/otherlibs/stdlib_alpha/capsule.mli | 2 +- ocaml/otherlibs/stdlib_alpha/dune | 4 +++- ocaml/testsuite/tests/capsule-api/basics.ml | 8 ++++++++ 4 files changed, 17 insertions(+), 4 deletions(-) diff --git a/ocaml/otherlibs/stdlib_alpha/capsule.ml b/ocaml/otherlibs/stdlib_alpha/capsule.ml index 71f8b113a8d..6bec2e5836a 100644 --- a/ocaml/otherlibs/stdlib_alpha/capsule.ml +++ b/ocaml/otherlibs/stdlib_alpha/capsule.ml @@ -27,7 +27,7 @@ end (* Like [Stdlib.Mutex], but [portable]. *) module M = struct - type t + type t : value mod portable uncontended external create: unit -> t @@ portable = "caml_ml_mutex_new" external lock: t -> unit @@ portable = "caml_ml_mutex_lock" external unlock: t -> unit @@ portable = "caml_ml_mutex_unlock" @@ -39,7 +39,10 @@ external reraise : exn -> 'a @ portable @@ portable = "%reraise" module Mutex = struct - type 'k t = { mutex : M.t; mutable poisoned : bool } + (* Illegal mode crossing: ['k t] has a mutable field [poisoned]. It's safe, + since [poisoned] protected by [mutex] and not exposed in the API, but + is not allowed by the type system. *) + type 'k t : value mod portable uncontended = { mutex : M.t; mutable poisoned : bool } type packed = P : 'k t -> packed diff --git a/ocaml/otherlibs/stdlib_alpha/capsule.mli b/ocaml/otherlibs/stdlib_alpha/capsule.mli index 42badc396b6..522a49d0409 100644 --- a/ocaml/otherlibs/stdlib_alpha/capsule.mli +++ b/ocaml/otherlibs/stdlib_alpha/capsule.mli @@ -64,7 +64,7 @@ end Requires OCaml 5 runtime. *) module Mutex : sig - type 'k t + type 'k t : value mod portable uncontended (** ['k t] is the type of the mutex that controls access to the capsule ['k]. This mutex is created when creating the capsule ['k] using {!create_with_mutex}. *) diff --git a/ocaml/otherlibs/stdlib_alpha/dune b/ocaml/otherlibs/stdlib_alpha/dune index 58267f70121..54c252d5711 100644 --- a/ocaml/otherlibs/stdlib_alpha/dune +++ b/ocaml/otherlibs/stdlib_alpha/dune @@ -24,7 +24,9 @@ -safe-string -strict-formats -extension-universe - alpha)) + alpha + ;; Capsule API can't be defined legally. + -allow-illegal-crossing)) (ocamlopt_flags (:include %{project_root}/ocamlopt_flags.sexp)) (library_flags diff --git a/ocaml/testsuite/tests/capsule-api/basics.ml b/ocaml/testsuite/tests/capsule-api/basics.ml index 335638b900e..9a38048e044 100644 --- a/ocaml/testsuite/tests/capsule-api/basics.ml +++ b/ocaml/testsuite/tests/capsule-api/basics.ml @@ -8,9 +8,17 @@ module Capsule = Stdlib_alpha.Capsule +(* Both [Mutex.t] and [Data.t] are [value mod portable uncontended]. *) + +type 'k _mutex : value mod portable uncontended = 'k Capsule.Mutex.t + +type ('a, 'k) _data : value mod portable uncontended = ('a, 'k) Capsule.Data.t + type 'a myref = { mutable v : 'a} module Cell = struct + (* CR: ['a Cell.t] should be [value mod portable uncontended], + but this can't be inferred yet. *) type 'a t = | Mk : 'k Capsule.Mutex.t * ('a myref, 'k) Capsule.Data.t -> 'a t From 982d7ba29dd1a9cc9f39e29e7163421f033ca3b1 Mon Sep 17 00:00:00 2001 From: Milan Tom <48379919+milan-tom@users.noreply.github.com> Date: Fri, 6 Sep 2024 13:13:44 +0100 Subject: [PATCH 18/76] Change profile output to simplify parsing for dynamic counters (#3016) * Add keys to function and block passes * Export sanitisation function for fields in profile CSV output * Don't sanitise out forward slashes for CSV (not strictly necessary) --- backend/asmgen.ml | 4 ++-- ocaml/utils/profile.ml | 8 ++++++-- ocaml/utils/profile.mli | 5 +++++ 3 files changed, 13 insertions(+), 4 deletions(-) diff --git a/backend/asmgen.ml b/backend/asmgen.ml index 2acc8c0b4f0..9bdef0d0d71 100644 --- a/backend/asmgen.ml +++ b/backend/asmgen.ml @@ -282,7 +282,7 @@ let cfg_profile to_cfg = let (_ : Cfg.basic_block) = Profile.record_with_counters ~accumulate:true ~counter_f:cfg_block_counters - (Format.sprintf "block %d" label) + (Format.sprintf "block=%d" label) Fun.id block in () @@ -573,7 +573,7 @@ let compile_phrases ~ppf_dump ps = let profile_wrapper = match !profile_granularity with | Function_level | Block_level -> - Profile.record ~accumulate:true fd.fun_name.sym_name + Profile.record ~accumulate:true ("function=" ^ fd.fun_name.sym_name) | File_level -> Fun.id in profile_wrapper (compile_fundecl ~ppf_dump ~funcnames) fd; diff --git a/ocaml/utils/profile.ml b/ocaml/utils/profile.ml index 16f10403c90..51ddca7ecec 100644 --- a/ocaml/utils/profile.ml +++ b/ocaml/utils/profile.ml @@ -398,9 +398,13 @@ let column_mapping = [ `Counters, "counters" ] +let sanitise_for_csv = + String.map (fun c -> if Char.equal c ',' then '_' else c) + let output_to_csv ppf columns = - let sanitise = String.map (fun c -> if c = ',' then '_' else c) in - let to_csv cell_strings = cell_strings |> List.map sanitise |> String.concat "," in + let to_csv cell_strings = + cell_strings |> List.map sanitise_for_csv |> String.concat "," + in let string_columns = List.map (fun col -> List.assoc col column_mapping) columns in Format.fprintf ppf "%s@\n" (to_csv ("pass name" :: string_columns)); let output_row_f = output_rows diff --git a/ocaml/utils/profile.mli b/ocaml/utils/profile.mli index f6512b3b5b8..0785c2e18f7 100644 --- a/ocaml/utils/profile.mli +++ b/ocaml/utils/profile.mli @@ -57,6 +57,11 @@ val record_with_counters : val print : Format.formatter -> Clflags.profile_column list -> timings_precision:int -> unit (** Prints the selected recorded profiling information to the formatter. *) +(* CR mitom: Exported for use with external tools to create dynamic counters *) +val sanitise_for_csv : string -> string +(** Sanitises a given string such that it is suitable to be used as a field in outputted + CSV files *) + val output_to_csv : Format.formatter -> Clflags.profile_column list -> timings_precision:int -> unit (** Outputs the selected recorded profiling information in CSV format to the formatter. *) From c60ecf1570656673c261c229b28a2987b16cc6ce Mon Sep 17 00:00:00 2001 From: Greta Yorsh <45005955+gretay-js@users.noreply.github.com> Date: Fri, 6 Sep 2024 17:28:22 +0300 Subject: [PATCH 19/76] Fix assertion failure: some reinterpret cast are not pure (#3017) Some reinterpret casts are not pure --- backend/cfg/cfg.ml | 4 ++-- backend/cfg/cfg.mli | 2 ++ backend/zero_alloc_checker.ml | 12 ++++++++++-- 3 files changed, 14 insertions(+), 4 deletions(-) diff --git a/backend/cfg/cfg.ml b/backend/cfg/cfg.ml index 7b97fef004f..9ed2c50acae 100644 --- a/backend/cfg/cfg.ml +++ b/backend/cfg/cfg.ml @@ -281,7 +281,7 @@ let intop (op : Mach.integer_operation) = | Ictz _ -> " ctz " | Icomp cmp -> intcomp cmp -let dump_op ppf = function +let dump_operation ppf = function | Move -> Format.fprintf ppf "mov" | Spill -> Format.fprintf ppf "spill" | Reload -> Format.fprintf ppf "reload" @@ -323,7 +323,7 @@ let dump_op ppf = function let dump_basic ppf (basic : basic) = let open Format in match basic with - | Op op -> dump_op ppf op + | Op op -> dump_operation ppf op | Reloadretaddr -> fprintf ppf "Reloadretaddr" | Pushtrap { lbl_handler } -> fprintf ppf "Pushtrap handler=%d" lbl_handler | Poptrap -> fprintf ppf "Poptrap" diff --git a/backend/cfg/cfg.mli b/backend/cfg/cfg.mli index 9add04bd7b8..a82331bdd99 100644 --- a/backend/cfg/cfg.mli +++ b/backend/cfg/cfg.mli @@ -202,6 +202,8 @@ val set_stack_offset : 'a instruction -> int -> unit val string_of_irc_work_list : irc_work_list -> string +val dump_operation : Format.formatter -> operation -> unit + val dump_basic : Format.formatter -> basic -> unit val dump_terminator : ?sep:string -> Format.formatter -> terminator -> unit diff --git a/backend/zero_alloc_checker.ml b/backend/zero_alloc_checker.ml index da14f5ba202..c2f450e5f2a 100644 --- a/backend/zero_alloc_checker.ml +++ b/backend/zero_alloc_checker.ml @@ -2550,9 +2550,17 @@ end = struct | Intop ( Iadd | Isub | Imul | Imulh _ | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Ipopcnt | Iclz _ | Ictz _ | Icomp _ ) - | Reinterpret_cast _ | Static_cast _ | Csel _ -> - assert (Cfg.is_pure_operation op); + | Reinterpret_cast + ( Float32_of_float | Float_of_float32 | Float_of_int64 + | Int64_of_float | Float32_of_int32 | Int32_of_float32 + | V128_of_v128 ) + | Static_cast _ | Csel _ -> + if not (Cfg.is_pure_operation op) + then + Misc.fatal_errorf "Expected pure operation, got %a\n" + Cfg.dump_operation op; next + | Reinterpret_cast (Int_of_value | Value_of_int) | Name_for_debugger _ | Stackoffset _ | Probe_is_enabled _ | Opaque | Begin_region | End_region | Intop_atomic _ | Store _ -> next From 04511e6a71177c764be211dd1640df5ec0fffb52 Mon Sep 17 00:00:00 2001 From: dkalinichenko-js <118547217+dkalinichenko-js@users.noreply.github.com> Date: Fri, 6 Sep 2024 10:59:48 -0400 Subject: [PATCH 20/76] Mark `Mutex.packed` as portable and uncontended (#3018) Co-authored-by: Diana Kalinichenko --- ocaml/otherlibs/stdlib_alpha/capsule.ml | 4 +++- ocaml/otherlibs/stdlib_alpha/capsule.mli | 2 +- ocaml/testsuite/tests/capsule-api/basics.ml | 4 ++++ 3 files changed, 8 insertions(+), 2 deletions(-) diff --git a/ocaml/otherlibs/stdlib_alpha/capsule.ml b/ocaml/otherlibs/stdlib_alpha/capsule.ml index 6bec2e5836a..9b2bd366e4c 100644 --- a/ocaml/otherlibs/stdlib_alpha/capsule.ml +++ b/ocaml/otherlibs/stdlib_alpha/capsule.ml @@ -44,7 +44,9 @@ module Mutex = struct is not allowed by the type system. *) type 'k t : value mod portable uncontended = { mutex : M.t; mutable poisoned : bool } - type packed = P : 'k t -> packed + (* CR: illegal mode crossing on the current version of the compiler, + but should be legal. *) + type packed : value mod portable uncontended = P : 'k t -> packed exception Poisoned diff --git a/ocaml/otherlibs/stdlib_alpha/capsule.mli b/ocaml/otherlibs/stdlib_alpha/capsule.mli index 522a49d0409..9f41f06bd1f 100644 --- a/ocaml/otherlibs/stdlib_alpha/capsule.mli +++ b/ocaml/otherlibs/stdlib_alpha/capsule.mli @@ -69,7 +69,7 @@ module Mutex : sig the capsule ['k]. This mutex is created when creating the capsule ['k] using {!create_with_mutex}. *) - type packed = P : 'k t -> packed + type packed : value mod portable uncontended = P : 'k t -> packed (** [packed] is the type of a mutex for some unknown capsule. Unpacking one provides a ['k Mutex.t] together with a fresh existential type brand for ['k]. *) diff --git a/ocaml/testsuite/tests/capsule-api/basics.ml b/ocaml/testsuite/tests/capsule-api/basics.ml index 9a38048e044..34eb5071d33 100644 --- a/ocaml/testsuite/tests/capsule-api/basics.ml +++ b/ocaml/testsuite/tests/capsule-api/basics.ml @@ -14,6 +14,10 @@ type 'k _mutex : value mod portable uncontended = 'k Capsule.Mutex.t type ('a, 'k) _data : value mod portable uncontended = ('a, 'k) Capsule.Data.t +(* Packed mutexes are [value mod portable uncontended]. *) + +type _packed : value mod portable uncontended = Capsule.Mutex.packed + type 'a myref = { mutable v : 'a} module Cell = struct From fd9f79255868690b2988de8427db7ab2cc051945 Mon Sep 17 00:00:00 2001 From: ITO444 <61408991+ITO444@users.noreply.github.com> Date: Fri, 6 Sep 2024 11:32:09 -0400 Subject: [PATCH 21/76] Find independent adjacent store groups (#2940) --- backend/amd64/arch.ml | 82 +++++ backend/amd64/arch.mli | 12 + backend/arm64/arch.ml | 31 ++ backend/arm64/arch.mli | 12 + backend/cfg/vectorize.ml | 718 +++++++++++++++++++++++++++++++++++--- backend/cfg/vectorize.mli | 3 + backend/cmm.ml | 8 + backend/cmm.mli | 2 + backend/reg.ml | 3 + backend/reg.mli | 1 + 10 files changed, 822 insertions(+), 50 deletions(-) diff --git a/backend/amd64/arch.ml b/backend/amd64/arch.ml index 9259a26ac6b..7e64f4bc72d 100644 --- a/backend/amd64/arch.ml +++ b/backend/amd64/arch.ml @@ -403,3 +403,85 @@ let equal_specific_operation left right = Isextend32 | Izextend32 | Irdtsc | Irdpmc | Ilfence | Isfence | Imfence | Ipause | Isimd _ | Iprefetch _), _ -> false + +(* addressing mode functions *) + +let compare_addressing_mode_without_displ (addressing_mode_1: addressing_mode) (addressing_mode_2 : addressing_mode) = + (* Ignores displ when comparing to show that it is possible to calculate the offset *) + match addressing_mode_1, addressing_mode_2 with + | Ibased (symbol1, global1, _), Ibased (symbol2, global2, _) -> ( + match global1, global2 with + | Global, Global | Local, Local -> + String.compare symbol1 symbol2 + | Global, Local -> -1 + | Local, Global -> 1) + | Ibased _, _ -> -1 + | _, Ibased _ -> 1 + | Iindexed _, Iindexed _ -> 0 + | Iindexed _, _ -> -1 + | _, Iindexed _ -> 1 + | Iindexed2 _, Iindexed2 _ -> 0 + | Iindexed2 _, _ -> -1 + | _, Iindexed2 _ -> 1 + | Iscaled (scale1, _), Iscaled (scale2, _) -> Int.compare scale1 scale2 + | Iscaled _, _ -> -1 + | _, Iscaled _ -> 1 + | Iindexed2scaled (scale1, _), Iindexed2scaled (scale2, _) -> + Int.compare scale1 scale2 + +let compare_addressing_mode_displ (addressing_mode_1: addressing_mode) (addressing_mode_2 : addressing_mode) = + match addressing_mode_1, addressing_mode_2 with + | Ibased (symbol1, global1, n1), Ibased (symbol2, global2, n2) -> ( + match global1, global2 with + | Global, Global | Local, Local -> + if symbol1 = symbol2 then Some (Int.compare n1 n2) else None + | Global, Local | Local, Global -> None) + | Iindexed n1, Iindexed n2 -> Some (Int.compare n1 n2) + | Iindexed2 n1, Iindexed2 n2 -> Some (Int.compare n1 n2) + | Iscaled (scale1, n1), Iscaled (scale2, n2) -> + let scale_compare = scale1 - scale2 in + if scale_compare = 0 then Some (Int.compare n1 n2) else None + | Iindexed2scaled (scale1, n1), Iindexed2scaled (scale2, n2) -> + let scale_compare = scale1 - scale2 in + if scale_compare = 0 then Some (Int.compare n1 n2) else None + | Ibased _, _ -> None + | Iindexed _, _ -> None + | Iindexed2 _, _ -> None + | Iscaled _, _ -> None + | Iindexed2scaled _, _ -> None + +let addressing_offset_in_bytes (addressing_mode_1: addressing_mode) (addressing_mode_2 : addressing_mode) = + match addressing_mode_1, addressing_mode_2 with + | Ibased (symbol1, global1, n1), Ibased (symbol2, global2, n2) -> ( + match global1, global2 with + | Global, Global | Local, Local -> + if symbol1 = symbol2 then Some (n2 - n1) else None + | Global, Local | Local, Global -> None) + | Iindexed n1, Iindexed n2 -> Some (n2 - n1) + | Iindexed2 n1, Iindexed2 n2 -> Some (n2 - n1) + | Iscaled (scale1, n1), Iscaled (scale2, n2) -> + let scale_compare = scale1 - scale2 in + if scale_compare = 0 then Some (n2 - n1) else None + | Iindexed2scaled (scale1, n1), Iindexed2scaled (scale2, n2) -> + let scale_compare = scale1 - scale2 in + if scale_compare = 0 then Some (n2 - n1) else None + | Ibased _, _ -> None + | Iindexed _, _ -> None + | Iindexed2 _, _ -> None + | Iscaled _, _ -> None + | Iindexed2scaled _, _ -> None + + let can_cross_loads_or_stores (specific_operation : specific_operation) = + match specific_operation with + | Ilea _ | Istore_int _ | Ioffset_loc _ | Ifloatarithmem _ | Isimd _ | Iprefetch _ -> + false + | Ibswap _ | Isextend32 | Izextend32 | Irdtsc | Irdpmc | Ilfence | Isfence | Imfence + | Ipause -> + true + + let may_break_alloc_freshness (specific_operation : specific_operation) = + match specific_operation with + | Isimd _ -> true + | Ilea _ | Istore_int _ | Ioffset_loc _ | Ifloatarithmem _ | Ibswap _ | Isextend32 + | Izextend32 | Irdtsc | Irdpmc | Ilfence | Isfence | Imfence | Ipause | Iprefetch _ -> + false diff --git a/backend/amd64/arch.mli b/backend/amd64/arch.mli index fdde8d8bba5..40372c54008 100644 --- a/backend/amd64/arch.mli +++ b/backend/amd64/arch.mli @@ -138,3 +138,15 @@ val operation_allocates : specific_operation -> bool val float_cond_and_need_swap : Lambda.float_comparison -> X86_ast.float_condition * bool + +(* addressing mode functions *) + +val compare_addressing_mode_without_displ : addressing_mode -> addressing_mode -> int + +val compare_addressing_mode_displ : addressing_mode -> addressing_mode -> int option + +val addressing_offset_in_bytes : addressing_mode -> addressing_mode -> int option + +val can_cross_loads_or_stores : specific_operation -> bool + +val may_break_alloc_freshness : specific_operation -> bool diff --git a/backend/arm64/arch.ml b/backend/arm64/arch.ml index 4a16a6a65bf..a4cea1589d1 100644 --- a/backend/arm64/arch.ml +++ b/backend/arm64/arch.ml @@ -331,3 +331,34 @@ let operation_allocates = function | Ishiftarith (_, _) | Isignext _ | Ibswap _ -> false + +(* See `amd64/arch.ml`. *) + +let compare_addressing_mode_without_displ (addressing_mode_1: addressing_mode) (addressing_mode_2 : addressing_mode) = + match addressing_mode_1, addressing_mode_2 with + | Iindexed _, Iindexed _ -> 0 + | Iindexed _ , _ -> -1 + | _, Iindexed _ -> 1 + | Ibased (var1, _), Ibased (var2, _) -> String.compare var1 var2 + +let compare_addressing_mode_displ (addressing_mode_1: addressing_mode) (addressing_mode_2 : addressing_mode) = + match addressing_mode_1, addressing_mode_2 with + | Iindexed n1, Iindexed n2 -> Some (Int.compare n1 n2) + | Ibased (var1, n1), Ibased (var2, n2) -> + if String.compare var1 var2 = 0 then Some (Int.compare n1 n2) else None + | Iindexed _ , _ -> None + | Ibased _ , _ -> None + +let addressing_offset_in_bytes (addressing_mode_1: addressing_mode) (addressing_mode_2 : addressing_mode) = None + +let can_cross_loads_or_stores (specific_operation : specific_operation) = + match specific_operation with + | Ifar_poll _ | Ifar_alloc _ | Ishiftarith _ | Imuladd | Imulsub | Inegmulf | Imuladdf + | Inegmuladdf | Imulsubf | Inegmulsubf | Isqrtf | Ibswap _ | Imove32 | Isignext _ -> + true + +let may_break_alloc_freshness (specific_operation : specific_operation) = + match specific_operation with + | Ifar_poll _ | Ifar_alloc _ | Ishiftarith _ | Imuladd | Imulsub | Inegmulf | Imuladdf + | Inegmuladdf | Imulsubf | Inegmulsubf | Isqrtf | Ibswap _ | Imove32 | Isignext _ -> + false diff --git a/backend/arm64/arch.mli b/backend/arm64/arch.mli index bc9da8e4610..06d9de3ab92 100644 --- a/backend/arm64/arch.mli +++ b/backend/arm64/arch.mli @@ -115,3 +115,15 @@ val operation_allocates : specific_operation -> bool (* Specific operations that can raise *) val operation_can_raise : specific_operation -> bool + +(* See `amd64/arch.mli`. *) + +val compare_addressing_mode_without_displ : addressing_mode -> addressing_mode -> int + +val compare_addressing_mode_displ : addressing_mode -> addressing_mode -> int option + +val addressing_offset_in_bytes : addressing_mode -> addressing_mode -> int option + +val can_cross_loads_or_stores : specific_operation -> bool + +val may_break_alloc_freshness : specific_operation -> bool diff --git a/backend/cfg/vectorize.ml b/backend/cfg/vectorize.ml index 0295ae92ffd..24cbad76318 100644 --- a/backend/cfg/vectorize.ml +++ b/backend/cfg/vectorize.ml @@ -1,9 +1,15 @@ [@@@ocaml.warning "+a-40-41-42"] +(* Finds independent scalar operations within the same basic block and tries to + use vector operations if possible *) +(* CR-soon tip: add documentation *) + module DLL = Flambda_backend_utils.Doubly_linked_list let ( << ) f g x = f (g x) +let vector_width_in_bytes = 16 + module Instruction : sig (* CR-someday tip: consider moving this to cfg or at least have something similar there *) @@ -28,6 +34,14 @@ module Instruction : sig val destroyed : t -> Reg.t Array.t val print : Format.formatter -> t -> unit + + val is_store : t -> bool + + val is_alloc : t -> bool + + val can_cross_loads_or_stores : t -> bool + + val may_break_alloc_freshness : t -> bool end = struct module Id = struct include Numbers.Int @@ -63,6 +77,89 @@ end = struct match instruction with | Basic i -> Cfg.print_basic ppf i | Terminator i -> Cfg.print_terminator ppf i + + let is_store (instruction : t) = + match instruction with + | Basic basic_instruction -> ( + let desc = basic_instruction.desc in + match desc with + | Op op -> ( + match op with + | Store _ -> true + | Load _ | Alloc _ | Move | Reinterpret_cast _ | Static_cast _ | Spill + | Reload | Const_int _ | Const_float32 _ | Const_float _ + | Const_symbol _ | Const_vec128 _ | Stackoffset _ | Intop _ + | Intop_imm _ | Intop_atomic _ | Floatop _ | Csel _ | Probe_is_enabled _ + | Opaque | Begin_region | End_region | Specific _ | Name_for_debugger _ + | Dls_get | Poll -> + false) + | Reloadretaddr | Pushtrap _ | Poptrap | Prologue | Stack_check _ -> false + ) + | Terminator _ -> false + + let is_alloc (instruction : t) = + match instruction with + | Basic basic_instruction -> ( + let desc = basic_instruction.desc in + match desc with + | Op op -> ( + match op with + | Alloc _ -> true + | Load _ | Store _ | Move | Reinterpret_cast _ | Static_cast _ | Spill + | Reload | Const_int _ | Const_float32 _ | Const_float _ + | Const_symbol _ | Const_vec128 _ | Stackoffset _ | Intop _ + | Intop_imm _ | Intop_atomic _ | Floatop _ | Csel _ | Probe_is_enabled _ + | Opaque | Begin_region | End_region | Specific _ | Name_for_debugger _ + | Dls_get | Poll -> + false) + | Reloadretaddr | Pushtrap _ | Poptrap | Prologue | Stack_check _ -> false + ) + | Terminator _ -> false + + let can_cross_loads_or_stores (instruction : t) = + (* CR-someday tip: some instructions may or may not cause issues for going + across a load or a store, for simplicity's sake, let's just return false + and not let them go across for now, but better handling can be added in + the future. Also, loads from an immuntable block has no coeffects and may + have less restrictions *) + match instruction with + | Basic basic_instruction -> ( + let desc = basic_instruction.desc in + match desc with + | Op op -> ( + match op with + | Load _ | Store _ | Intop_atomic _ | Alloc _ | Poll | Opaque + | Begin_region | End_region -> + false + | Specific specific_operation -> + Arch.can_cross_loads_or_stores specific_operation + | Move | Reinterpret_cast _ | Static_cast _ | Spill | Reload + | Const_int _ | Const_float32 _ | Const_float _ | Const_symbol _ + | Const_vec128 _ | Stackoffset _ | Intop _ | Intop_imm _ | Floatop _ + | Csel _ | Probe_is_enabled _ | Name_for_debugger _ | Dls_get -> + true) + | Reloadretaddr | Pushtrap _ | Poptrap | Prologue | Stack_check _ -> true) + | Terminator _ -> false + + let may_break_alloc_freshness (instruction : t) = + match instruction with + | Basic basic_instruction -> ( + let desc = basic_instruction.desc in + match desc with + | Op op -> ( + match op with + | Load _ | Store _ -> true + | Specific specific_operation -> + Arch.may_break_alloc_freshness specific_operation + | Alloc _ | Move | Reinterpret_cast _ | Static_cast _ | Spill | Reload + | Const_int _ | Const_float32 _ | Const_float _ | Const_symbol _ + | Const_vec128 _ | Stackoffset _ | Intop _ | Intop_imm _ + | Intop_atomic _ | Floatop _ | Csel _ | Probe_is_enabled _ | Opaque + | Begin_region | End_region | Name_for_debugger _ | Dls_get | Poll -> + false) + | Reloadretaddr | Pushtrap _ | Poptrap | Prologue | Stack_check _ -> false + ) + | Terminator _ -> false end module Dependency_graph : sig @@ -70,25 +167,36 @@ module Dependency_graph : sig same basic block *) type t - val from_cfg : Cfg.t -> t + val from_block : Cfg.basic_block -> t + + val get_all_dependencies_of_arg : + t -> Instruction.Id.t -> arg_i:int -> Instruction.Id.Set.t - val dump : Format.formatter -> t -> Cfg_with_layout.t -> unit + val dump : Format.formatter -> t -> Cfg.basic_block -> unit end = struct module Node = struct module Reg_node = struct type t = { reg : Reg.t; - depends_on : Instruction.Id.t option + direct_dependency : Instruction.Id.t option + (* the most recent instruction in this basic block that may change + the value of the argument *) } - let init reg : t = { reg; depends_on = None } + let init reg : t = { reg; direct_dependency = None } end type t = { instruction : Instruction.t; reg_nodes : Reg_node.t array; - depends_on : Instruction.Id.Set.t; - is_dependency_of : Instruction.Id.Set.t + direct_dependencies : Instruction.Id.Set.t; + (* direct dependencies of all arguments of this instruction *) + all_dependencies : Instruction.Id.Set.t; + (* direct dependencies of this instruction and all dependencies of + each direct dependency of this instruction *) + is_direct_dependency_of : Instruction.Id.Set.t + (* all instructions that have this instruction as a direct + dependency *) } let init instruction : t = @@ -97,8 +205,9 @@ end = struct reg_nodes = Array.init (Array.length arguments) (fun i -> arguments.(i) |> Reg_node.init); - depends_on = Instruction.Id.Set.empty; - is_dependency_of = Instruction.Id.Set.empty + direct_dependencies = Instruction.Id.Set.empty; + all_dependencies = Instruction.Id.Set.empty; + is_direct_dependency_of = Instruction.Id.Set.empty } end @@ -110,26 +219,46 @@ end = struct let replace = Instruction.Id.Tbl.replace - let init () : t = Instruction.Id.Tbl.create 100 + let init ~size : t = Instruction.Id.Tbl.create size + + let get_all_dependencies dependency_graph id = + let (node : Node.t) = Instruction.Id.Tbl.find dependency_graph id in + node.all_dependencies + + let get_all_dependencies_of_arg dependency_graph id ~arg_i = + let (node : Node.t) = Instruction.Id.Tbl.find dependency_graph id in + match node.reg_nodes.(arg_i).direct_dependency with + | None -> Instruction.Id.Set.empty + | Some direct_dependency -> + get_all_dependencies dependency_graph direct_dependency + |> Instruction.Id.Set.add direct_dependency - let from_basic_block (block : Cfg.basic_block) ~(dependency_graph : t) = + let from_block (block : Cfg.basic_block) = + let dependency_graph = init ~size:(DLL.length block.body) in let is_changed_in instruction reg = Array.exists (Reg.same reg) (Instruction.results instruction) || Array.exists (Reg.same reg) (Instruction.destroyed instruction) in - (* CR-soon tip: break it into 2 parts to find the instruction we want then - go up from there. (currently it loops from the end and changes the answer - back to None when it encounters the same instruction) *) let latest_change ~(current : Instruction.Id.t) (reg : Reg.t) = - DLL.fold_right block.body - ~f:(fun basic_instruction latest -> - let instruction = Instruction.Basic basic_instruction in - if Instruction.Id.equal current (Instruction.id instruction) - then None - else if Option.is_none latest && is_changed_in instruction reg + let starting_cell = + match + DLL.find_cell_opt block.body ~f:(fun instruction -> + Basic instruction |> Instruction.id + |> Instruction.Id.equal current) + with + | None -> DLL.last_cell block.body + | Some current_cell -> DLL.prev current_cell + in + let rec find_latest_change cell_option = + match cell_option with + | None -> None + | Some cell -> + let instruction = Instruction.Basic (DLL.value cell) in + if is_changed_in instruction reg then Some instruction - else latest) - ~init:None + else find_latest_change (DLL.prev cell) + in + find_latest_change starting_cell in let add_arg_dependency instruction arg_i arg = let id = Instruction.id instruction in @@ -138,7 +267,7 @@ end = struct let reg_node = node.reg_nodes.(arg_i) in node.reg_nodes.(arg_i) <- { reg_node with - depends_on = + direct_dependency = Option.fold ~none:None ~some:(Option.some << Instruction.id) dependency @@ -156,18 +285,26 @@ end = struct let arg_indices = Instruction.arguments instruction |> Array.mapi (fun arg_i _ -> arg_i) in - let instruction_dependencies = + let direct_dependencies = Array.fold_left (fun dependencies arg_i -> Option.fold ~none:dependencies ~some:(fun dependency -> Instruction.Id.Set.add dependency dependencies) - (find dependency_graph id).reg_nodes.(arg_i).depends_on) + (find dependency_graph id).reg_nodes.(arg_i).direct_dependency) Instruction.Id.Set.empty arg_indices in + let all_dependencies = + Instruction.Id.Set.fold + (fun new_id old_indirect_dependencies -> + let node = Instruction.Id.Tbl.find dependency_graph new_id in + Instruction.Id.Set.union node.direct_dependencies + old_indirect_dependencies) + direct_dependencies direct_dependencies + in let node = find dependency_graph id in replace dependency_graph id - { node with depends_on = instruction_dependencies } + { node with direct_dependencies; all_dependencies } in let add_all_dependencies () = DLL.iter block.body ~f:(fun instruction -> @@ -178,38 +315,35 @@ end = struct let dependency = find dependency_graph dependency_id in replace dependency_graph dependency_id { dependency with - is_dependency_of = - Instruction.Id.Set.add instruction_id dependency.is_dependency_of + is_direct_dependency_of = + Instruction.Id.Set.add instruction_id + dependency.is_direct_dependency_of } in let set_is_dependency_of_plural (instruction : Instruction.t) = let id = Instruction.id instruction in let node = find dependency_graph id in - Instruction.Id.Set.iter (set_is_dependency_of id) node.depends_on + Instruction.Id.Set.iter (set_is_dependency_of id) node.direct_dependencies in let set_all_is_dependency_of () = DLL.iter block.body ~f:(fun instruction -> - set_is_dependency_of_plural (Basic instruction)) + set_is_dependency_of_plural (Basic instruction)); + set_is_dependency_of_plural (Terminator block.terminator) in add_all_dependencies (); - set_all_is_dependency_of () - - let from_cfg (cfg : Cfg.t) : t = - let dependency_graph = init () in - Cfg.iter_blocks cfg ~f:(fun _ block -> - from_basic_block block ~dependency_graph); + set_all_is_dependency_of (); dependency_graph - let dump ppf (t : t) cfg_with_layout = + let dump ppf (t : t) (block : Cfg.basic_block) = let open Format in let print_reg_node arg_i (reg_node : Node.Reg_node.t) = let dependency = Option.fold ~none:"none" ~some:(sprintf "instruction %d" << Instruction.Id.to_int) - reg_node.depends_on + reg_node.direct_dependency in - fprintf ppf "\nargument %d (reg %d) depends on %s\n" arg_i - reg_node.reg.stamp dependency + fprintf ppf "argument %d, %a depends on %s\n" arg_i Printmach.reg + reg_node.reg dependency in let print_node (instruction : Instruction.t) = let id = Instruction.id instruction in @@ -217,22 +351,490 @@ end = struct fprintf ppf "\n%d:\n" (Instruction.id node.instruction |> Instruction.Id.to_int); Instruction.print ppf instruction; - Array.iteri print_reg_node node.reg_nodes; - fprintf ppf "\ndepends on:\n"; + fprintf ppf "\ndirect dependencies:\n"; Instruction.Id.Set.iter (fprintf ppf "%d " << Instruction.Id.to_int) - node.depends_on; - fprintf ppf "\nis a dependency of:\n"; + node.direct_dependencies; + fprintf ppf "\nall dependencies:\n"; Instruction.Id.Set.iter (fprintf ppf "%d " << Instruction.Id.to_int) - node.is_dependency_of; + node.all_dependencies; + fprintf ppf "\nis direct dependency of:\n"; + Instruction.Id.Set.iter + (fprintf ppf "%d " << Instruction.Id.to_int) + node.is_direct_dependency_of; fprintf ppf "\narg dependencies:\n"; + Array.iteri print_reg_node node.reg_nodes; fprintf ppf "\n" in fprintf ppf "\ndependency graph:\n"; - Cfg_with_layout.iter_instructions cfg_with_layout - ~instruction:(fun instruction -> print_node (Basic instruction)) - ~terminator:(fun instruction -> print_node (Terminator instruction)) + DLL.iter block.body ~f:(fun instruction -> print_node (Basic instruction)); + print_node (Terminator block.terminator); + fprintf ppf "\n" +end + +module Memory_accesses : sig + module Memory_operation : sig + type t + + val instruction : t -> Instruction.t + + val is_adjacent : t -> t -> bool + + val width : t -> int + + val dump : Format.formatter -> t -> unit + end + + type t + + val stores : t -> Instruction.Id.t list + + val get_memory_operation_exn : t -> Instruction.Id.t -> Memory_operation.t + + val from_block : Cfg.basic_block -> t + + val can_cross : t -> Instruction.t -> Instruction.t -> bool + + val dump : Format.formatter -> t -> unit +end = struct + module Memory_operation = struct + type op = + | Load + | Store + + type t = + { op : op; + memory_chunk : Cmm.memory_chunk; + addressing_mode : Arch.addressing_mode; + instruction : Instruction.t; + dependent_allocs : Instruction.Id.Set.t; + unsure_allocs : Instruction.Id.Set.t + } + + let instruction t = t.instruction + + let init (instruction : Instruction.t) : t option = + match instruction with + | Basic basic_instruction -> ( + let desc = basic_instruction.desc in + match desc with + | Op op -> ( + match op with + | Load { memory_chunk; addressing_mode; _ } -> + Some + { op = Load; + memory_chunk; + addressing_mode; + instruction; + dependent_allocs = Instruction.Id.Set.empty; + unsure_allocs = Instruction.Id.Set.empty + } + | Store (memory_chunk, addressing_mode, _) -> + Some + { op = Store; + memory_chunk; + addressing_mode; + instruction; + dependent_allocs = Instruction.Id.Set.empty; + unsure_allocs = Instruction.Id.Set.empty + } + | Specific _ -> + None + (* CR-someday tip: may need to rewrite a lot of code to handle loads + and stores inside [Specific] in the future *) + | Move | Reinterpret_cast _ | Static_cast _ | Spill | Reload + | Const_int _ | Const_float32 _ | Const_float _ | Const_symbol _ + | Const_vec128 _ | Stackoffset _ | Intop _ | Intop_imm _ + | Intop_atomic _ | Floatop _ | Csel _ | Probe_is_enabled _ | Opaque + | Begin_region | End_region | Name_for_debugger _ | Dls_get | Poll + | Alloc _ -> + None) + | Reloadretaddr | Pushtrap _ | Poptrap | Prologue | Stack_check _ -> + None) + | Terminator _ -> None + + let memory_arguments (t : t) = + let arguments = Instruction.arguments t.instruction in + match t.op with + | Load -> arguments + | Store -> Array.sub arguments 1 (Array.length arguments - 1) + + let width (t : t) = Cmm.width_in_bytes t.memory_chunk + + let print_memory_chunk ppf (t : t) = + Format.fprintf ppf "%s (length %d)" + (Printcmm.chunk t.memory_chunk) + (Cmm.width_in_bytes t.memory_chunk) + + let dump ppf (t : t) = + let open Format in + let instruction = t.instruction in + let print_set ppf set = + Instruction.Id.Set.iter + (fun id -> fprintf ppf "%d " (Instruction.Id.to_int id)) + set + in + fprintf ppf + "\n\ + Instruction %d: %a (%a, %a)\n\ + \ dependent allocs: %a\n\ + \ unsure_allocs: %a" + (Instruction.id instruction |> Instruction.Id.to_int) + Instruction.print instruction print_memory_chunk t + (Arch.print_addressing Printmach.reg t.addressing_mode) + (memory_arguments t) print_set t.dependent_allocs print_set + t.unsure_allocs + + let compare_arguments (t1 : t) (t2 : t) = + let arguments_1 = memory_arguments t1 in + let arguments_2 = memory_arguments t2 in + Array.combine arguments_1 arguments_2 + |> Array.fold_left + (fun result ((arg1, arg2) : Reg.t * Reg.t) -> + if result = 0 then Reg.compare arg1 arg2 else result) + 0 + + let compare_addressing_modes_and_arguments (t1 : t) (t2 : t) = + let addressing_mode_comparison = + Arch.compare_addressing_mode_without_displ t1.addressing_mode + t2.addressing_mode + in + if addressing_mode_comparison = 0 + then + let arguments_comparison = compare_arguments t1 t2 in + arguments_comparison + else addressing_mode_comparison + + let offset_in_bytes (t1 : t) (t2 : t) = + let addressing_mode_and_arguments_comparison = + compare_addressing_modes_and_arguments t1 t2 + in + if addressing_mode_and_arguments_comparison = 0 + then Arch.addressing_offset_in_bytes t1.addressing_mode t2.addressing_mode + else None + + let is_adjacent (t1 : t) (t2 : t) = + let res = + if Cmm.equal_memory_chunk t1.memory_chunk t2.memory_chunk + then + let width = Cmm.width_in_bytes t1.memory_chunk in + let offset_option = offset_in_bytes t1 t2 in + match offset_option with + | None -> false + | Some offset -> width = offset + else false + in + res + + let index_offset t = match t.op with Load -> 0 | Store -> 1 + end + + type t = + { loads : Instruction.Id.t list; + stores : Instruction.Id.t list; + memory_operations : Memory_operation.t Instruction.Id.Tbl.t + } + + let stores t = t.stores + + let get_memory_operation_exn t id = + Instruction.Id.Tbl.find t.memory_operations id + + type alloc_tracker = + { loads : Instruction.Id.t list; + stores : Instruction.Id.t list; + fresh_allocs : Instruction.Id.Set.t; + stored_allocs : Instruction.Id.Set.t; + unsure_allocs : Instruction.Id.Set.t + } + + let from_block (block : Cfg.basic_block) : t = + (* A heuristic to avoid treating the same "fresh" allocation which address + stored and loaded into a different register as different, has room for + improvement. Assumption: if x depends on a fresh allocation, and it is + certain that y does not depend on that fresh allocation, then they point + to disjoint addresses *) + (* At each load or store instruction, it keeps track of all allocs up to + this point in this basic block and puts them in one of 3 categories: + [fresh_allocs]: nothing that depends on the address of the fresh alloc + has been saved as a value; [stored_allocs]: something that depends on the + address of the fresh alloc has been saved as a value, but nothing has + been loaded till this point; [unsure_allocs]: something that depends on + the address of the fresh alloc has been saved as a value, and something + has been loaded till this point. For each memory operation, we will save + its dependent allocs and unsure allocs *) + let dependency_graph = Dependency_graph.from_block block in + let id_to_instructions = + DLL.to_list block.body + |> List.map (fun basic_instruction -> + let instruction = Instruction.Basic basic_instruction in + Instruction.id instruction, instruction) + |> Instruction.Id.Tbl.of_list + in + let memory_operations = Instruction.Id.Tbl.create (DLL.length block.body) in + let ({ loads; stores; _ } : alloc_tracker) = + DLL.fold_left block.body + ~f: + (fun { loads; stores; fresh_allocs; stored_allocs; unsure_allocs } + basic_instruction -> + let instruction = Instruction.Basic basic_instruction in + let id = Instruction.id instruction in + if Instruction.is_alloc instruction + then + { loads; + stores; + fresh_allocs = Instruction.Id.Set.add id fresh_allocs; + stored_allocs; + unsure_allocs + } + else + let memory_operation = Memory_operation.init instruction in + match memory_operation with + | None -> + if Instruction.may_break_alloc_freshness instruction + then + { loads; + stores; + fresh_allocs = Instruction.Id.Set.empty; + stored_allocs = Instruction.Id.Set.empty; + unsure_allocs = + Instruction.Id.Set.union fresh_allocs stored_allocs + |> Instruction.Id.Set.union unsure_allocs + } + else { loads; stores; fresh_allocs; stored_allocs; unsure_allocs } + | Some memory_operation -> ( + let get_dependent_allocs_of_arg arg_i = + Dependency_graph.get_all_dependencies_of_arg dependency_graph id + ~arg_i + |> Instruction.Id.Set.filter + (Instruction.is_alloc + << Instruction.Id.Tbl.find id_to_instructions) + in + let rec get_dependent_allocs arg_i = + if arg_i < 0 + then Instruction.Id.Set.empty + else + Instruction.Id.Set.union + (get_dependent_allocs_of_arg + (arg_i + Memory_operation.index_offset memory_operation)) + (get_dependent_allocs (arg_i - 1)) + in + let dependent_allocs = + get_dependent_allocs + (Array.length + (Memory_operation.memory_arguments memory_operation) + - 1) + in + Instruction.Id.Tbl.add memory_operations id + { memory_operation with dependent_allocs; unsure_allocs }; + match memory_operation.op with + | Load -> + { loads = id :: loads; + stores; + fresh_allocs; + stored_allocs = Instruction.Id.Set.empty; + unsure_allocs = + Instruction.Id.Set.union stored_allocs unsure_allocs + } + | Store -> + let new_stored_allocs = + Instruction.Id.Set.diff + (get_dependent_allocs_of_arg 0) + unsure_allocs + in + { loads; + stores = id :: stores; + fresh_allocs = + Instruction.Id.Set.diff fresh_allocs new_stored_allocs; + stored_allocs = + Instruction.Id.Set.union stored_allocs new_stored_allocs; + unsure_allocs + })) + ~init: + { loads = []; + stores = []; + fresh_allocs = Instruction.Id.Set.empty; + stored_allocs = Instruction.Id.Set.empty; + unsure_allocs = Instruction.Id.Set.empty + } + in + { loads = List.rev loads; stores = List.rev stores; memory_operations } + + let can_cross (t : t) (instruction_1 : Instruction.t) + (instruction_2 : Instruction.t) = + let get_memory_operation instruction = + Instruction.Id.Tbl.find_opt t.memory_operations + (Instruction.id instruction) + in + match + get_memory_operation instruction_1, get_memory_operation instruction_2 + with + | None, _ | _, None -> + (* Make sure that they are not both "dangerous", ie. thinigs like allocs + or specific stores *) + Instruction.can_cross_loads_or_stores instruction_1 + || Instruction.can_cross_loads_or_stores instruction_2 + | Some memory_operation_1, Some memory_operation_2 -> ( + match memory_operation_1.op, memory_operation_2.op with + | Load, Load -> true + | Load, Store | Store, Load | Store, Store -> + if Memory_operation.compare_addressing_modes_and_arguments + memory_operation_1 memory_operation_2 + = 0 + then + let check_direct_separation left_memory_operation + right_memory_operation = + match + Memory_operation.offset_in_bytes left_memory_operation + right_memory_operation + with + | None -> false + | Some offset -> + offset + >= (left_memory_operation.Memory_operation.memory_chunk + |> Cmm.width_in_bytes) + in + check_direct_separation memory_operation_1 memory_operation_2 + || check_direct_separation memory_operation_2 memory_operation_1 + else + (* Assumption: If memory operation 1 definitely depends on an + allocation and memory operation 2 definitely does not depend on it, + then they are disjoint *) + Instruction.Id.Set.is_empty + (Instruction.Id.Set.diff memory_operation_1.dependent_allocs + (Instruction.Id.Set.union memory_operation_2.dependent_allocs + memory_operation_2.unsure_allocs)) + || Instruction.Id.Set.is_empty + (Instruction.Id.Set.diff memory_operation_2.dependent_allocs + (Instruction.Id.Set.union memory_operation_1.dependent_allocs + memory_operation_1.unsure_allocs))) + + let dump ppf ({ loads; stores; memory_operations } : t) = + let open Format in + let print_list list = + List.iter + (fun id -> + let address = Instruction.Id.Tbl.find memory_operations id in + Memory_operation.dump ppf address) + list + in + fprintf ppf "\nmemory accesses (loads):\n"; + print_list loads; + fprintf ppf "\nmemory accesses (stores):\n"; + print_list stores; + fprintf ppf "\n" +end + +module Seed : sig + type t + + val from_block : Cfg.basic_block -> t list + + val dump : Format.formatter -> t list -> unit +end = struct + type t = Memory_accesses.Memory_operation.t list + + let can_cross memory_accesses instruction_1 instruction_2 = + let reg_array_to_set = Reg.Set.of_list << Array.to_list in + let argument_set = reg_array_to_set << Instruction.arguments + and affected_set instruction = + Reg.Set.union + (Instruction.results instruction |> reg_array_to_set) + (Instruction.destroyed instruction |> reg_array_to_set) + in + let arguments_1 = argument_set instruction_1 + and affected_1 = affected_set instruction_1 + and arguments_2 = argument_set instruction_2 + and affected_2 = affected_set instruction_2 in + if Reg.Set.disjoint affected_1 affected_2 + && Reg.Set.disjoint arguments_1 affected_2 + && Reg.Set.disjoint affected_1 arguments_2 + then Memory_accesses.can_cross memory_accesses instruction_1 instruction_2 + else false + + let from_block (block : Cfg.basic_block) : t list = + (* For each store instruction, it tries to form a seed with the closest + stores after it, it will go down the DLL of instructions and tries to + move the store instructions across the non-store instructions until all + the store instructions are together *) + let memory_accesses = Memory_accesses.from_block block in + let stores = Memory_accesses.stores memory_accesses in + List.filter_map + (fun store_id -> + let starting_cell = + match + DLL.find_cell_opt block.body ~f:(fun instruction -> + Basic instruction |> Instruction.id + |> Instruction.Id.equal store_id) + with + | Some current_cell -> DLL.next current_cell + | None -> assert false + in + let starting_memory_operation = + Memory_accesses.get_memory_operation_exn memory_accesses store_id + in + let items_in_vector = + vector_width_in_bytes + / Memory_accesses.Memory_operation.width starting_memory_operation + in + let can_cross_chunk seed instruction = + List.fold_left + (fun can memory_operation -> + can + && can_cross memory_accesses + (Memory_accesses.Memory_operation.instruction + memory_operation) + instruction) + true seed + in + let rec find_seed n seed cell_option = + if n = 0 + then Some seed + else + match cell_option with + | None -> None + | Some cell -> + let instruction = Instruction.Basic (DLL.value cell) in + if Instruction.is_store instruction + then + let new_store = + Instruction.id instruction + |> Memory_accesses.get_memory_operation_exn memory_accesses + in + if Memory_accesses.Memory_operation.is_adjacent (List.hd seed) + new_store + then find_seed (n - 1) (new_store :: seed) (DLL.next cell) + else None + else if can_cross_chunk seed instruction + then find_seed n seed (DLL.next cell) + else None + in + find_seed (items_in_vector - 1) + [starting_memory_operation] + starting_cell + |> Option.map List.rev) + stores + + let dump ppf (seeds : t list) = + let open Format in + let print_seed seed = + List.iter + (fun (address : Memory_accesses.Memory_operation.t) -> + Memory_accesses.Memory_operation.dump ppf address) + seed + in + let print_seeds seeds = + List.iter + (fun seed -> + fprintf ppf "("; + print_seed seed; + fprintf ppf "\n)\n") + seeds + in + fprintf ppf "\nseeds:\n"; + print_seeds seeds; + fprintf ppf "\n" end let dump ppf cfg_with_layout ~msg = @@ -255,8 +857,24 @@ let cfg ppf_dump cl = if !Flambda_backend_flags.dump_vectorize then Format.fprintf ppf_dump "*** Vectorization@."; let cfg = Cfg_with_layout.cfg cl in - let dependency_graph = Dependency_graph.from_cfg cfg in - if !Flambda_backend_flags.dump_vectorize - then Dependency_graph.dump ppf_dump dependency_graph cl; + let layout = Cfg_with_layout.layout cl in + DLL.iter layout ~f:(fun label -> + let block = Cfg.get_block_exn cfg label in + let instruction_count = DLL.length block.body in + Format.fprintf ppf_dump "\nBlock %d (%d basic instructions):\n" label + instruction_count; + if instruction_count > 1000 + then + Format.fprintf ppf_dump + "more than 1000 instructions in basic block, cannot vectorize\n" + else + let dependency_graph = Dependency_graph.from_block block in + if !Flambda_backend_flags.dump_vectorize + then Dependency_graph.dump ppf_dump dependency_graph block; + let memory_accesses = Memory_accesses.from_block block in + if !Flambda_backend_flags.dump_vectorize + then Memory_accesses.dump ppf_dump memory_accesses; + let seeds = Seed.from_block block in + if !Flambda_backend_flags.dump_vectorize then Seed.dump ppf_dump seeds); if !Flambda_backend_flags.dump_vectorize then dump ppf_dump ~msg:"" cl; cl diff --git a/backend/cfg/vectorize.mli b/backend/cfg/vectorize.mli index abdc35ffb75..4fd105ed9e7 100644 --- a/backend/cfg/vectorize.mli +++ b/backend/cfg/vectorize.mli @@ -1 +1,4 @@ +(* Finds independent scalar operations within the same basic block and tries to + use vector operations if possible *) + val cfg : Format.formatter -> Cfg_with_layout.t -> Cfg_with_layout.t diff --git a/backend/cmm.ml b/backend/cmm.ml index 6876553186d..209c021e5f5 100644 --- a/backend/cmm.ml +++ b/backend/cmm.ml @@ -357,6 +357,14 @@ type phrase = Cfunction of fundecl | Cdata of data_item list +let width_in_bytes (memory_chunk : memory_chunk) : int = + match memory_chunk with + | Byte_unsigned | Byte_signed -> 1 + | Sixteen_unsigned | Sixteen_signed -> 2 + | Thirtytwo_unsigned | Thirtytwo_signed | Single _ -> 4 + | Word_int | Word_val | Double -> 8 + | Onetwentyeight_unaligned | Onetwentyeight_aligned -> 16 + let ccatch (i, ids, e1, e2, dbg, kind, is_cold) = Ccatch(Nonrecursive, [i, ids, e2, dbg, is_cold], e1, kind) diff --git a/backend/cmm.mli b/backend/cmm.mli index a2e12434803..2737943d5a0 100644 --- a/backend/cmm.mli +++ b/backend/cmm.mli @@ -371,6 +371,8 @@ type phrase = Cfunction of fundecl | Cdata of data_item list +val width_in_bytes : memory_chunk -> int + val ccatch : label * (Backend_var.With_provenance.t * machtype) list * expression * expression * Debuginfo.t * kind_for_unboxing diff --git a/backend/reg.ml b/backend/reg.ml index 8e5cb3c2262..78077b04e78 100644 --- a/backend/reg.ml +++ b/backend/reg.ml @@ -344,6 +344,9 @@ let same_loc left right = let same left right = Int.equal left.stamp right.stamp +let compare left right = + Int.compare left.stamp right.stamp + (* Two registers have compatible types if we allow moves between them. Note that we never allow moves between different register classes, so this condition must be at least as strict as [class left = class right]. *) diff --git a/backend/reg.mli b/backend/reg.mli index b1e392d8ce0..328f4e7e7a1 100644 --- a/backend/reg.mli +++ b/backend/reg.mli @@ -128,3 +128,4 @@ val types_are_compatible : t -> t -> bool val same_phys_reg : t -> t -> bool val same_loc : t -> t -> bool val same : t -> t -> bool +val compare : t -> t -> int From 4b06f1928848af7c31aabe74f26a3f5a9b8818a5 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 9 Sep 2024 12:47:32 +0100 Subject: [PATCH 22/76] Fixes to Select_utils required by previous merge --- backend/select_utils.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/backend/select_utils.ml b/backend/select_utils.ml index 8f29af49ea5..e7f62e70ba6 100644 --- a/backend/select_utils.ml +++ b/backend/select_utils.ml @@ -193,6 +193,7 @@ let oper_result_type = function | Cprobe _ -> typ_void | Cprobe_is_enabled _ -> typ_int | Copaque -> typ_val + | Cpoll -> typ_void | Cbeginregion -> (* This must not be typ_val; the begin-region operation returns a naked pointer into the local allocation stack. *) @@ -500,7 +501,7 @@ class virtual ['env, 'op, 'instr] common_selector = List.for_all self#is_simple_expr args (* The following may have side effects *) | Capply _ | Cextcall _ | Calloc _ | Cstore _ | Craise _ | Catomic _ - | Cprobe _ | Cprobe_is_enabled _ | Copaque -> + | Cprobe _ | Cprobe_is_enabled _ | Copaque | Cpoll -> false | Cprefetch _ | Cbeginregion | Cendregion -> false @@ -547,7 +548,7 @@ class virtual ['env, 'op, 'instr] common_selector = match op with | Cextcall { effects = e; coeffects = ce } -> EC.create (select_effects e) (select_coeffects ce) - | Capply _ | Cprobe _ | Copaque -> EC.arbitrary + | Capply _ | Cprobe _ | Copaque | Cpoll -> EC.arbitrary | Calloc Alloc_heap -> EC.none | Calloc Alloc_local -> EC.coeffect_only Coeffect.Arbitrary | Cstore _ -> EC.effect_only Effect.Arbitrary From 3970ad5e7ca99cfb1e60dd8c5e256669fe1ff726 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 9 Sep 2024 13:13:28 +0100 Subject: [PATCH 23/76] Merge fixes --- ocaml/driver/compile_common.ml | 2 +- ocaml/parsing/ast_iterator.ml | 9 ------- ocaml/typing/ctype.ml | 2 +- ocaml/typing/printtyp.ml | 16 ++++++------ ocaml/typing/typecore.ml | 46 ++++++---------------------------- ocaml/typing/typedecl.ml | 8 +++--- 6 files changed, 19 insertions(+), 64 deletions(-) diff --git a/ocaml/driver/compile_common.ml b/ocaml/driver/compile_common.ml index 88f86c7866d..f5f01f436ef 100644 --- a/ocaml/driver/compile_common.ml +++ b/ocaml/driver/compile_common.ml @@ -57,7 +57,7 @@ let parse_intf i = let typecheck_intf info ast = Profile.( record_call_with_counters - ~counter_f:(fun signature -> + ~counter_f:(fun (_alerts, signature) -> Profile_counters_functions.( count_language_extensions (Typedtree_signature_output signature))) typing) diff --git a/ocaml/parsing/ast_iterator.ml b/ocaml/parsing/ast_iterator.ml index 7382d4f6639..c3b5928c1ab 100644 --- a/ocaml/parsing/ast_iterator.ml +++ b/ocaml/parsing/ast_iterator.ml @@ -506,15 +506,6 @@ module E = struct iter_loc_txt sub sub.jkind_annotation jkind; sub.expr sub inner_expr - let iter_labeled_tuple sub : LT.expression -> _ = function - | el -> List.iter (iter_snd (sub.expr sub)) el - - let iter_jst sub : Jane_syntax.Expression.t -> _ = function - | Jexp_comprehension comp_exp -> iter_comp_exp sub comp_exp - | Jexp_immutable_array iarr_exp -> iter_iarr_exp sub iarr_exp - | Jexp_layout layout_exp -> iter_layout_exp sub layout_exp - | Jexp_tuple lt_exp -> iter_labeled_tuple sub lt_exp - let iter_function_param sub : function_param -> _ = fun { pparam_loc = loc; pparam_desc = desc } -> sub.location sub loc; diff --git a/ocaml/typing/ctype.ml b/ocaml/typing/ctype.ml index e37a73f02f0..5386b4159e2 100644 --- a/ocaml/typing/ctype.ml +++ b/ocaml/typing/ctype.ml @@ -3718,7 +3718,7 @@ and unify3 uenv t1 t1' t2 t2' = | true, true -> () end | (Ttuple labeled_tl1, Ttuple labeled_tl2) -> - unify_labeled_list env labeled_tl1 labeled_tl2 + unify_labeled_list uenv labeled_tl1 labeled_tl2 | (Tunboxed_tuple labeled_tl1, Tunboxed_tuple labeled_tl2) -> unify_labeled_list uenv labeled_tl1 labeled_tl2 | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> diff --git a/ocaml/typing/printtyp.ml b/ocaml/typing/printtyp.ml index 612ea47a9e9..f7dfb90ef7f 100644 --- a/ocaml/typing/printtyp.ml +++ b/ocaml/typing/printtyp.ml @@ -1856,9 +1856,8 @@ let tree_of_type_decl id decl = let ty_manifest, params = prepare_decl id decl in let type_param ot_variance ot_jkind = function - | Otyp_var (ot_non_gen, ot_name) -> - {ot_non_gen; ot_name; ot_variance; ot_jkind} - | _ -> {ot_non_gen=false; ot_name="?"; ot_variance; ot_jkind} + | Otyp_var (_, id) -> id + | _ -> "?" in let type_defined decl = let abstr = @@ -1892,12 +1891,11 @@ let tree_of_type_decl id decl = else (NoVariance, NoInjectivity)) decl.type_params decl.type_variance in - let mk_param ty variance = - let jkind = param_jkind ty in - type_param variance jkind (tree_of_typexp Type ty) - in - (Ident.name id, - List.map2 mk_param params vari) + let mk_param ty (variance, injectivity) = + { oparam_name = type_param (tree_of_typexp Type ty); + oparam_variance = variance; + oparam_injectivity = injectivity; + oparam_jkind = param_jkind ty } in let tree_of_manifest ty1 = match ty_manifest with diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index 32e2a82ef13..40bff454467 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -1487,7 +1487,7 @@ let solve_Ppat_tuple ~refine ~alloc_mode loc env args expected_ty = (* This assumes the [args] have already been reordered according to the [expected_ty], if needed. *) -let solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc env args expected_ty = +let solve_Ppat_unboxed_tuple ~alloc_mode loc env args expected_ty = let arity = List.length args in let arg_modes = match alloc_mode.tuple_modes with @@ -1513,7 +1513,7 @@ let solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc env args expected_ty = newgenty (Tunboxed_tuple (List.map (fun (lbl, _, t, _, _) -> lbl, t) ann)) in let expected_ty = generic_instance expected_ty in - unify_pat_types ~refine loc env ty expected_ty; + unify_pat_types loc env ty expected_ty; ann let solve_constructor_annotation @@ -2523,18 +2523,18 @@ and type_pat_aux Jane_syntax_parsing.assert_extension_enabled ~loc Layouts Language_extension.Beta; let args = - match get_desc (expand_head !env expected_ty) with + match get_desc (expand_head !!penv expected_ty) with (* If it's a principally-known tuple pattern, try to reorder *) | Tunboxed_tuple labeled_tl when is_principal expected_ty -> - reorder_pat loc env spl closed labeled_tl expected_ty + reorder_pat loc penv spl closed labeled_tl expected_ty (* If not, it's not allowed to be open (partial) *) | _ -> match closed with - | Open -> raise (Error (loc, !env, Partial_tuple_pattern_bad_type)) + | Open -> raise (Error (loc, !!penv, Partial_tuple_pattern_bad_type)) | Closed -> spl in let spl_ann = - solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc env args expected_ty + solve_Ppat_unboxed_tuple ~alloc_mode loc !!penv args expected_ty in let pl = List.map (fun (lbl, p, t, alloc_mode, sort) -> @@ -2551,38 +2551,6 @@ and type_pat_aux pat_attributes = sp.ppat_attributes; pat_env = !!penv } in - let type_unboxed_tuple_pat spl closed = - Jane_syntax_parsing.assert_extension_enabled ~loc Layouts - Language_extension.Beta; - let args = - match get_desc (expand_head !env expected_ty) with - (* If it's a principally-known tuple pattern, try to reorder *) - | Tunboxed_tuple labeled_tl when is_principal expected_ty -> - reorder_pat loc env spl closed labeled_tl expected_ty - (* If not, it's not allowed to be open (partial) *) - | _ -> - match closed with - | Open -> raise (Error (loc, !env, Partial_tuple_pattern_bad_type)) - | Closed -> spl - in - let spl_ann = - solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc env args expected_ty - in - let pl = - List.map (fun (lbl, p, t, alloc_mode, sort) -> - lbl, type_pat tps Value ~alloc_mode p t, sort) - spl_ann - in - let ty = - newty (Tunboxed_tuple (List.map (fun (lbl, p, _) -> lbl, p.pat_type) pl)) - in - rvp { - pat_desc = Tpat_unboxed_tuple pl; - pat_loc = loc; pat_extra=[]; - pat_type = ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env } - in match Jane_syntax.Pattern.of_ast sp with | Some (jpat, attrs) -> begin (* Normally this would go to an auxiliary function, but this function @@ -3343,7 +3311,7 @@ let rec check_counter_example_pat pl)))) | Tpat_unboxed_tuple tpl -> let tpl_ann = - solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc env + solve_Ppat_unboxed_tuple ~alloc_mode loc !!penv (List.map (fun (l,t,_) -> l, t) tpl) expected_ty in diff --git a/ocaml/typing/typedecl.ml b/ocaml/typing/typedecl.ml index f8cc23f032c..1ebffacc07b 100644 --- a/ocaml/typing/typedecl.ml +++ b/ocaml/typing/typedecl.ml @@ -2682,7 +2682,7 @@ let is_upstream_compatible_non_value_unbox env ty = | _ -> false -type sort_or_poly = Sort of Jkind.Sort.const | Poly +type sort_or_poly = Sort of Jkind.Sort.Const.t | Poly let native_repr_of_type env kind ty sort_or_poly = match kind, get_desc (Ctype.expand_head_opt env ty) with @@ -2694,8 +2694,8 @@ let native_repr_of_type env kind ty sort_or_poly = *) && match sort_or_poly with | Poly -> false - | Sort Value -> true - | Sort _ -> false + | Sort (Base Value) -> true + | Sort (Base _ | Product _) -> false -> Some Untagged_immediate | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float -> @@ -2757,8 +2757,6 @@ let type_sort_external ~is_layout_poly ~why env loc typ = in raise(Error (loc, Jkind_sort {kloc; typ; err})) -type sort_or_poly = Sort of Jkind.Sort.Const.t | Poly - let make_native_repr env core_type ty ~global_repr ~is_layout_poly ~why = error_if_has_deep_native_repr_attributes core_type; let sort_or_poly = From 764f730e5da69c373a7c03977e01b56893e9062f Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 9 Sep 2024 13:44:15 +0100 Subject: [PATCH 24/76] Dubious merge fixes --- ocaml/typing/oprint.ml | 12 +++--------- ocaml/typing/printtyp.ml | 27 ++++++++++++++++++--------- 2 files changed, 21 insertions(+), 18 deletions(-) diff --git a/ocaml/typing/oprint.ml b/ocaml/typing/oprint.ml index 29ff1d284bf..209015d5652 100644 --- a/ocaml/typing/oprint.ml +++ b/ocaml/typing/oprint.ml @@ -356,15 +356,9 @@ let print_out_jkind_const ppf ojkind = pp_element ~nested:false ppf ojkind let print_out_jkind ppf ojkind = - let rec pp_element ~nested ppf ojkind = - match ojkind with - | Ojkind_var v -> fprintf ppf "%s" v - | Ojkind_const jkind -> print_out_jkind_const ppf jkind - | Ojkind_product ts -> - let pp_sep ppf () = Format.fprintf ppf "@ & " in - Misc.pp_nested_list ~nested ~pp_element ~pp_sep ppf ts - in - pp_element ~nested:false ppf ojkind + match ojkind with + | Ojkind_var v -> fprintf ppf "%s" v + | Ojkind_const jkind -> print_out_jkind_const ppf jkind let print_out_jkind_annot ppf = function | None -> () diff --git a/ocaml/typing/printtyp.ml b/ocaml/typing/printtyp.ml index f7dfb90ef7f..ef3849aa352 100644 --- a/ocaml/typing/printtyp.ml +++ b/ocaml/typing/printtyp.ml @@ -1339,7 +1339,10 @@ let out_jkind_option_of_jkind jkind = | Const jkind -> out_jkind_of_const_jkind jkind | Var v -> Ojkind_var (Jkind.Sort.Var.name v) | Product jkinds -> - Ojkind_product (List.map desc_to_out_jkind jkinds) + Ojkind_const (Ojkind_const_product (List.map desc_to_out_const_jkind jkinds)) + and desc_to_out_const_jkind : Jkind.Desc.t -> out_jkind_const = function + | Const jkind -> Jkind.Const.to_out_jkind_const jkind + | Var _ | Product _ -> assert false (* XXX mshinwell *) in let desc = Jkind.get jkind in let elide = @@ -1856,8 +1859,9 @@ let tree_of_type_decl id decl = let ty_manifest, params = prepare_decl id decl in let type_param ot_variance ot_jkind = function - | Otyp_var (_, id) -> id - | _ -> "?" + | Otyp_var (ot_non_gen, ot_name) -> + {ot_non_gen; ot_name; ot_variance; ot_jkind} + | _ -> {ot_non_gen=false; ot_name="?"; ot_variance; ot_jkind} in let type_defined decl = let abstr = @@ -1891,11 +1895,12 @@ let tree_of_type_decl id decl = else (NoVariance, NoInjectivity)) decl.type_params decl.type_variance in - let mk_param ty (variance, injectivity) = - { oparam_name = type_param (tree_of_typexp Type ty); - oparam_variance = variance; - oparam_injectivity = injectivity; - oparam_jkind = param_jkind ty } + let mk_param ty variance = + let jkind = param_jkind ty in + type_param variance jkind (tree_of_typexp Type ty) + in + (Ident.name id, + List.map2 mk_param params vari) in let tree_of_manifest ty1 = match ty_manifest with @@ -2728,7 +2733,11 @@ let trees_of_type_expansion' let rec okind_of_desc : Jkind.Desc.t -> _ = function | Const clay -> out_jkind_of_const_jkind clay | Var v -> Ojkind_var (Jkind.Sort.Var.name v) - | Product ds -> Ojkind_product (List.map okind_of_desc ds) + | Product ds -> + Ojkind_const (Ojkind_const_product (List.map okind_const_of_desc ds)) + and okind_const_of_desc : Jkind.Desc.t -> _ = function + | Const const -> Jkind.Const.to_out_jkind_const const + | Var _ | Product _ -> assert false (* XXX mshinwell *) in let okind = okind_of_desc (Jkind.get jkind) in Otyp_jkind_annot (out, okind) From 8691c427ef0aee9181a2ebe655ea2ce631b22f5c Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 9 Sep 2024 15:14:53 +0100 Subject: [PATCH 25/76] Add jkind_axis to modules_without_implementation --- .vscode/settings.json | 1 + ocaml/otherlibs/dynlink/dune | 1 + 2 files changed, 2 insertions(+) diff --git a/.vscode/settings.json b/.vscode/settings.json index cf178580e70..ec2aa0906ad 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -17,4 +17,5 @@ "[ocaml.interface]": { "editor.defaultFormatter": "ocamllabs.ocaml-platform", }, + "makefile.configureOnOpen": false, } diff --git a/ocaml/otherlibs/dynlink/dune b/ocaml/otherlibs/dynlink/dune index 44b9a0fa175..c18a63058eb 100644 --- a/ocaml/otherlibs/dynlink/dune +++ b/ocaml/otherlibs/dynlink/dune @@ -161,6 +161,7 @@ debug_event solver_intf mode_intf + jkind_axis value_rec_types)) ;(install From bac195af1fb487ccea799943f5666403bd78bfae Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 9 Sep 2024 15:38:56 +0100 Subject: [PATCH 26/76] dynlink dune again --- ocaml/otherlibs/dynlink/dune | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/ocaml/otherlibs/dynlink/dune b/ocaml/otherlibs/dynlink/dune index c18a63058eb..72251a2c2a7 100644 --- a/ocaml/otherlibs/dynlink/dune +++ b/ocaml/otherlibs/dynlink/dune @@ -161,7 +161,6 @@ debug_event solver_intf mode_intf - jkind_axis value_rec_types)) ;(install @@ -265,7 +264,7 @@ (copy_files ../../typing/path.ml) -(copy_files ../../typing/typemodifier.ml) +(copy_files ../../typing/jkind_axis.ml) (copy_files ../../typing/jkind.ml) From 10e5ea580ce80a754ddcfd4383e747300c056d97 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 9 Sep 2024 16:18:43 +0100 Subject: [PATCH 27/76] Fix make runtest --- tests/backend/zero_alloc_checker/fail19.output | 3 ++- .../backend/zero_alloc_checker/test_assume_inlining.output | 6 ------ 2 files changed, 2 insertions(+), 7 deletions(-) diff --git a/tests/backend/zero_alloc_checker/fail19.output b/tests/backend/zero_alloc_checker/fail19.output index 6862e32941e..3226cbb1491 100644 --- a/tests/backend/zero_alloc_checker/fail19.output +++ b/tests/backend/zero_alloc_checker/fail19.output @@ -14,7 +14,8 @@ File "fail19.ml", line 13, characters 13-16: Error: called function may allocate (indirect call) File "fail19.ml", line 14, characters 15-44: -Error: expression may allocate (probe "test" handler camlFail19.probe_handler_test_HIDE_STAMP) +Error: expression may allocate + (probe "test" handler camlFail19.probe_handler_test_HIDE_STAMP) File "fail19.ml", line 14, characters 46-54: Error: allocation of 24 bytes diff --git a/tests/backend/zero_alloc_checker/test_assume_inlining.output b/tests/backend/zero_alloc_checker/test_assume_inlining.output index 2f075f39bd6..8155339f149 100644 --- a/tests/backend/zero_alloc_checker/test_assume_inlining.output +++ b/tests/backend/zero_alloc_checker/test_assume_inlining.output @@ -3,9 +3,3 @@ Error: Annotation check for zero_alloc failed on function Test_assume_inlining.A File "test_assume_inlining.ml", line 35, characters 4-9: Error: called function may allocate (direct call camlTest_assume_inlining.f_HIDE_STAMP) (test_assume_inlining.ml:35,4--9;test_assume_inlining.ml:30,6--9) - -File "test_assume_inlining.ml", line 109, characters 7-17: -Error: Annotation check for zero_alloc failed on function Test_assume_inlining.A6.foo (camlTest_assume_inlining.foo_HIDE_STAMP) - -File "test_assume_inlining.ml", line 110, characters 4-9: -Error: called function may allocate (direct call camlTest_assume_inlining.f_HIDE_STAMP) (test_assume_inlining.ml:110,4--9;test_assume_inlining.ml:105,6--9) From 1b890515104e7ee8817b1811343bc97dff89fc55 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 9 Sep 2024 16:31:41 +0100 Subject: [PATCH 28/76] Test fixes --- .../test10_main.byte.reference | 8 +- .../tests/typing-layouts-products/basics.ml | 137 ++++++++---------- 2 files changed, 67 insertions(+), 78 deletions(-) diff --git a/ocaml/testsuite/tests/lib-dynlink-initializers/test10_main.byte.reference b/ocaml/testsuite/tests/lib-dynlink-initializers/test10_main.byte.reference index d6a1b39c86f..29213773715 100644 --- a/ocaml/testsuite/tests/lib-dynlink-initializers/test10_main.byte.reference +++ b/ocaml/testsuite/tests/lib-dynlink-initializers/test10_main.byte.reference @@ -3,10 +3,10 @@ Raised at Stdlib.failwith in file "stdlib.ml", line 35, characters 17-33 Called from Test10_plugin.g in file "test10_plugin.ml", line 3, characters 2-21 Called from Test10_plugin.f in file "test10_plugin.ml", line 6, characters 2-6 Called from Test10_plugin in file "test10_plugin.ml", line 10, characters 2-6 -Called from Dynlink_internal_byte.Bytecode.run in file "otherlibs/dynlink/dynlink.ml", line 180, characters 16-25 -Re-raised at Dynlink_internal_byte.Bytecode.run in file "otherlibs/dynlink/dynlink.ml", lines 182-184, characters 6-39 +Called from Dynlink_internal_byte.Bytecode.run in file "otherlibs/dynlink/dynlink.ml", line 179, characters 16-25 +Re-raised at Dynlink_internal_byte.Bytecode.run in file "otherlibs/dynlink/dynlink.ml", lines 181-183, characters 6-137 Called from Dynlink_common.Make.load.(fun) in file "ocaml/otherlibs/dynlink/dynlink_common.ml", line 382, characters 13-56 Called from Stdlib__List.iter in file "list.ml", line 117, characters 12-15 -Called from Dynlink_common.Make.load in file "ocaml/otherlibs/dynlink/dynlink_common.ml", lines 378-387, characters 8-15 +Called from Dynlink_common.Make.load in file "ocaml/otherlibs/dynlink/dynlink_common.ml", lines 378-387, characters 8-392 Re-raised at Dynlink_common.Make.load in file "ocaml/otherlibs/dynlink/dynlink_common.ml", line 391, characters 8-17 -Called from Test10_main in file "test10_main.ml", lines 51-53, characters 13-7 +Called from Test10_main in file "test10_main.ml", lines 51-53, characters 13-69 diff --git a/ocaml/testsuite/tests/typing-layouts-products/basics.ml b/ocaml/testsuite/tests/typing-layouts-products/basics.ml index c45bdaf6d23..2e5cdf46865 100644 --- a/ocaml/testsuite/tests/typing-layouts-products/basics.ml +++ b/ocaml/testsuite/tests/typing-layouts-products/basics.ml @@ -34,9 +34,9 @@ Line 1, characters 23-39: 1 | type t_nope = string * #(string * bool) ^^^^^^^^^^^^^^^^ Error: Tuple element types must have layout value. - The layout of #(string * bool) is value & value + The layout of "#(string * bool)" is value & value because it is an unboxed tuple. - But the layout of #(string * bool) must be a sublayout of value + But the layout of "#(string * bool)" must be a sublayout of value because it's the type of a tuple element. |}] @@ -55,9 +55,9 @@ type t2_wrong : value & float64 & value = #(string option * t1) Line 1, characters 0-63: 1 | type t2_wrong : value & float64 & value = #(string option * t1) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The layout of type #(string option * t1) is value & (float64 & value) +Error: The layout of type "#(string option * t1)" is value & (float64 & value) because it is an unboxed tuple. - But the layout of type #(string option * t1) must be a sublayout of + But the layout of type "#(string option * t1)" must be a sublayout of value & float64 & value because of the definition of t2_wrong at line 1, characters 0-63. |}] @@ -76,8 +76,8 @@ type t4_wrong = #(int * int) t3 Line 1, characters 16-28: 1 | type t4_wrong = #(int * int) t3 ^^^^^^^^^^^^ -Error: This type #(int * int) should be an instance of type - ('a : value & bits64) +Error: This type "#(int * int)" should be an instance of type + "('a : value & bits64)" The layout of #(int * int) is value & value because it is an unboxed tuple. But the layout of #(int * int) must be a sublayout of value & bits64 @@ -101,7 +101,7 @@ type t9 = #(int * int64#) t7 Line 2, characters 11-15: 2 | type t10 = bool t6 ^^^^ -Error: This type bool should be an instance of type ('a : value & bits64) +Error: This type "bool" should be an instance of type "('a : value & bits64)" The layout of bool is value because it's an enumeration variant type (all constructors are constant). But the layout of bool must be a sublayout of value & bits64 @@ -114,8 +114,8 @@ and 'a t7_wrong = { x : #(int * int64) t6_wrong } Line 2, characters 24-38: 2 | and 'a t7_wrong = { x : #(int * int64) t6_wrong } ^^^^^^^^^^^^^^ -Error: This type #(int * int64) should be an instance of type - ('a : value & bits64) +Error: This type "#(int * int64)" should be an instance of type + "('a : value & bits64)" The layout of #(int * int64) is value & value because it is an unboxed tuple. But the layout of #(int * int64) must be a sublayout of value & bits64 @@ -149,8 +149,8 @@ val f_uvar_ok : ('a : float64 & value). 'a -> 'a t = Line 6, characters 28-30: 6 | let f_uvar_bad : 'a . 'a -> 'a t = fun x -> x ^^ -Error: This type ('a : value) should be an instance of type - ('b : float64 & value) +Error: This type "('a : value)" should be an instance of type + "('b : float64 & value)" The layout of 'a is value because it is or unifies with an unannotated universal variable. But the layout of 'a must overlap with float64 & value @@ -218,9 +218,9 @@ Line 1, characters 31-44: 1 | type poly_var_type = [ `Foo of #(int * bool) ] ^^^^^^^^^^^^^ Error: Polymorphic variant constructor argument types must have layout value. - The layout of #(int * bool) is value & value + The layout of "#(int * bool)" is value & value because it is an unboxed tuple. - But the layout of #(int * bool) must be a sublayout of value + But the layout of "#(int * bool)" must be a sublayout of value because it's the type of the field of a polymorphic variant. |}] @@ -229,8 +229,8 @@ let poly_var_term = `Foo #(1,2) Line 1, characters 25-31: 1 | let poly_var_term = `Foo #(1,2) ^^^^^^ -Error: This expression has type #('a * 'b) - but an expression was expected of type ('c : value) +Error: This expression has type "#('a * 'b)" + but an expression was expected of type "('c : value)" The layout of #('a * 'b) is '_representable_layout_158 & '_representable_layout_159 because it is an unboxed tuple. But the layout of #('a * 'b) must be a sublayout of value @@ -243,9 +243,9 @@ Line 1, characters 25-41: 1 | type tuple_type = (int * #(bool * float#)) ^^^^^^^^^^^^^^^^ Error: Tuple element types must have layout value. - The layout of #(bool * float#) is value & float64 + The layout of "#(bool * float#)" is value & float64 because it is an unboxed tuple. - But the layout of #(bool * float#) must be a sublayout of value + But the layout of "#(bool * float#)" must be a sublayout of value because it's the type of a tuple element. |}] @@ -254,8 +254,8 @@ let tuple_term = ("hi", #(1, 2)) Line 1, characters 24-31: 1 | let tuple_term = ("hi", #(1, 2)) ^^^^^^^ -Error: This expression has type #('a * 'b) - but an expression was expected of type ('c : value) +Error: This expression has type "#('a * 'b)" + but an expression was expected of type "('c : value)" The layout of #('a * 'b) is '_representable_layout_165 & '_representable_layout_166 because it is an unboxed tuple. But the layout of #('a * 'b) must be a sublayout of value @@ -267,7 +267,7 @@ type record = { x : #(int * bool) } Line 1, characters 0-35: 1 | type record = { x : #(int * bool) } ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Type #(int * bool) has layout value & value. +Error: Type "#(int * bool)" has layout "value & value". Records may not yet contain types of this layout. |}] @@ -276,7 +276,7 @@ type inlined_record = A of { x : #(int * bool) } Line 1, characters 22-48: 1 | type inlined_record = A of { x : #(int * bool) } ^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Type #(int * bool) has layout value & value. +Error: Type "#(int * bool)" has layout "value & value". Inlined records may not yet contain types of this layout. |}] @@ -285,7 +285,7 @@ type variant = A of #(int * bool) Line 1, characters 15-33: 1 | type variant = A of #(int * bool) ^^^^^^^^^^^^^^^^^^ -Error: Type #(int * bool) has layout value & value. +Error: Type "#(int * bool)" has layout "value & value". Variants may not yet contain types of this layout. |}] @@ -296,7 +296,7 @@ end Line 2, characters 10-23: 2 | val x : #(int * bool) ^^^^^^^^^^^^^ -Error: This type signature for x is not a value type. +Error: This type signature for "x" is not a value type. The layout of type #(int * bool) is value & value because it is an unboxed tuple. But the layout of type #(int * bool) must be a sublayout of value @@ -310,8 +310,8 @@ end Line 2, characters 6-7: 2 | let x = #(1, 2) ^ -Error: Types of top-level module bindings must have layout value, but - the type of x has layout value & value. +Error: Types of top-level module bindings must have layout "value", but + the type of "x" has layout "value & value". |}] type object_type = < x : #(int * bool) > @@ -320,9 +320,9 @@ Line 1, characters 21-38: 1 | type object_type = < x : #(int * bool) > ^^^^^^^^^^^^^^^^^ Error: Object field types must have layout value. - The layout of #(int * bool) is value & value + The layout of "#(int * bool)" is value & value because it is an unboxed tuple. - But the layout of #(int * bool) must be a sublayout of value + But the layout of "#(int * bool)" must be a sublayout of value because it's the type of an object field. |}] @@ -346,8 +346,8 @@ class class_ = Line 3, characters 15-21: 3 | method x = #(1,2) ^^^^^^ -Error: This expression has type #('a * 'b) - but an expression was expected of type ('c : value) +Error: This expression has type "#('a * 'b)" + but an expression was expected of type "('c : value)" The layout of #('a * 'b) is '_representable_layout_194 & '_representable_layout_195 because it is an unboxed tuple. But the layout of #('a * 'b) must be a sublayout of value @@ -363,8 +363,8 @@ end;; Line 3, characters 17-21: 3 | let #(x,y) = utup in ^^^^ -Error: This expression has type ('a : value) - but an expression was expected of type #('b * 'c) +Error: This expression has type "('a : value)" + but an expression was expected of type "#('b * 'c)" The layout of #('a * 'b) is '_representable_layout_206 & '_representable_layout_207 because it is an unboxed tuple. But the layout of #('a * 'b) must be a sublayout of value @@ -494,11 +494,8 @@ module type S_constrain_type_jkind_deeper' = type t3 = #(t2 * bool * int64#) type t4 = #(float# * t3 * int) end -type ('a : float64 & ((value & float64) & value & bits64) & value) - t_constraint -module F : - functor (X : S_constrain_type_jkind_deeper') -> - sig type r = X.t4 t_constraint end +Uncaught exception: File "ocaml/typing/printtyp.ml", line 1345, characters 27-33: Assertion failed + |}] (***********************************************) @@ -699,9 +696,9 @@ val e1 : unit = () Line 2, characters 37-44: 2 | let[@warning "-26"] e2 = let rec x = #(1, y) and y = 42 in () ^^^^^^^ -Error: This expression has type #('a * 'b) - but an expression was expected of type ('c : value) - The layout of #('a * 'b) is '_representable_layout_366 & '_representable_layout_367 +Error: This expression has type "#('a * 'b)" + but an expression was expected of type "('c : value)" + The layout of #('a * 'b) is '_representable_layout_350 & '_representable_layout_351 because it is an unboxed tuple. But the layout of #('a * 'b) must be a sublayout of value because it's the type of the recursive variable x. @@ -715,9 +712,9 @@ let _ = let rec _x = #(3, 10) and _y = 42 in 42 Line 1, characters 21-29: 1 | let _ = let rec _x = #(3, 10) and _y = 42 in 42 ^^^^^^^^ -Error: This expression has type #('a * 'b) - but an expression was expected of type ('c : value) - The layout of #('a * 'b) is '_representable_layout_373 & '_representable_layout_374 +Error: This expression has type "#('a * 'b)" + but an expression was expected of type "('c : value)" + The layout of #('a * 'b) is '_representable_layout_357 & '_representable_layout_358 because it is an unboxed tuple. But the layout of #('a * 'b) must be a sublayout of value because it's the type of the recursive variable _x. @@ -731,7 +728,7 @@ type ('a : value & value) t = A of 'a [@@unboxed] Line 1, characters 30-37: 1 | type ('a : value & value) t = A of 'a [@@unboxed] ^^^^^^^ -Error: Type 'a has layout value & value. +Error: Type "'a" has layout "value & value". Unboxed variants may not yet contain types of this layout. |}] @@ -740,7 +737,7 @@ type t = A of #(int * int) [@@unboxed] Line 1, characters 9-26: 1 | type t = A of #(int * int) [@@unboxed] ^^^^^^^^^^^^^^^^^ -Error: Type #(int * int) has layout value & value. +Error: Type "#(int * int)" has layout "value & value". Unboxed variants may not yet contain types of this layout. |}] @@ -749,7 +746,7 @@ type ('a : value & value) t = A of { x : 'a } [@@unboxed] Line 1, characters 37-43: 1 | type ('a : value & value) t = A of { x : 'a } [@@unboxed] ^^^^^^ -Error: Type 'a has layout value & value. +Error: Type "'a" has layout "value & value". Unboxed inlined records may not yet contain types of this layout. |}] @@ -758,7 +755,7 @@ type t = A of { x : #(int * int) } [@@unboxed] Line 1, characters 16-32: 1 | type t = A of { x : #(int * int) } [@@unboxed] ^^^^^^^^^^^^^^^^ -Error: Type #(int * int) has layout value & value. +Error: Type "#(int * int)" has layout "value & value". Unboxed inlined records may not yet contain types of this layout. |}] @@ -773,9 +770,8 @@ type t3 = #(int * bool) array type t4 = #(string * #(float# * bool option)) array [%%expect{| type ('a : value & value) t1 = 'a array -type ('a : bits64 & (value & float64)) t2 = 'a array -type t3 = #(int * bool) array -type t4 = #(string * #(float# * bool option)) array +Uncaught exception: File "ocaml/typing/printtyp.ml", line 1345, characters 27-33: Assertion failed + |}] (* CR layouts v7.1: This example demonstrates a bug in type inference that we @@ -790,15 +786,8 @@ let _ = [| #(1,2) |] Line 1, characters 11-17: 1 | let _ = [| #(1,2) |] ^^^^^^ -Error: This expression has type #('a * 'b) - but an expression was expected of type - ('c : '_representable_layout_397 & '_representable_layout_398) - The kind of #('a * 'b) is - '_representable_layout_397 & '_representable_layout_398 - because it is an unboxed tuple. - But the kind of #('a * 'b) must be a subkind of - '_representable_layout_397 & '_representable_layout_398 - because it's the type of an array element. +Error: Uncaught exception: Typecore.Error(_, _, _) + |}] let _ = Array.init 3 (fun _ -> #(1,2)) @@ -806,9 +795,9 @@ let _ = Array.init 3 (fun _ -> #(1,2)) Line 1, characters 31-37: 1 | let _ = Array.init 3 (fun _ -> #(1,2)) ^^^^^^ -Error: This expression has type #('a * 'b) - but an expression was expected of type ('c : value) - The layout of #('a * 'b) is '_representable_layout_404 & '_representable_layout_405 +Error: This expression has type "#('a * 'b)" + but an expression was expected of type "('c : value)" + The layout of #('a * 'b) is '_representable_layout_380 & '_representable_layout_381 because it is an unboxed tuple. But the layout of #('a * 'b) must be a sublayout of value because of layout requirements from an imported definition. @@ -830,7 +819,7 @@ let _ = make 3 #(1,2) Lines 1-2, characters 0-18: 1 | external[@layout_poly] make : ('a : any) . int -> 'a -> 'a array = 2 | "caml_make_vect" -Error: Attribute [@layout_poly] can only be used on built-in primitives. +Error: Attribute "[@layout_poly]" can only be used on built-in primitives. |}] external[@layout_poly] array_get : ('a : any) . 'a array -> int -> 'a = @@ -874,9 +863,9 @@ class product_instance_variable x = Line 2, characters 25-26: 2 | let sum = let #(a,b) = x in a + b in ^ -Error: This expression has type ('a : value) - but an expression was expected of type #('b * 'c) - The layout of #('a * 'b) is '_representable_layout_450 & '_representable_layout_451 +Error: This expression has type "('a : value)" + but an expression was expected of type "#('b * 'c)" + The layout of #('a * 'b) is '_representable_layout_426 & '_representable_layout_427 because it is an unboxed tuple. But the layout of #('a * 'b) must be a sublayout of value because it's the type of a term-level argument to a class constructor. @@ -891,9 +880,9 @@ let x = lazy #(1,2) Line 1, characters 13-19: 1 | let x = lazy #(1,2) ^^^^^^ -Error: This expression has type #('a * 'b) - but an expression was expected of type ('c : value) - The layout of #('a * 'b) is '_representable_layout_455 & '_representable_layout_456 +Error: This expression has type "#('a * 'b)" + but an expression was expected of type "('c : value)" + The layout of #('a * 'b) is '_representable_layout_431 & '_representable_layout_432 because it is an unboxed tuple. But the layout of #('a * 'b) must be a sublayout of value because it's the type of a lazy expression. @@ -905,7 +894,7 @@ type t = #(int * int) lazy_t Line 1, characters 9-21: 1 | type t = #(int * int) lazy_t ^^^^^^^^^^^^ -Error: This type #(int * int) should be an instance of type ('a : value) +Error: This type "#(int * int)" should be an instance of type "('a : value)" The layout of #(int * int) is value & value because it is an unboxed tuple. But the layout of #(int * int) must be a sublayout of value @@ -929,8 +918,8 @@ let g (x : #(int * int)) = f (x :> #(t * t)) Line 1, characters 29-44: 1 | let g (x : #(int * int)) = f (x :> #(t * t)) ^^^^^^^^^^^^^^^ -Error: Type #(int * int) is not a subtype of #(t * t) - Type int is not a subtype of t +Error: Type "#(int * int)" is not a subtype of "#(t * t)" + Type "int" is not a subtype of "t" |}] (************************************************) @@ -941,9 +930,9 @@ let f_optional_utuple ?(x = #(1,2)) () = x Line 1, characters 28-34: 1 | let f_optional_utuple ?(x = #(1,2)) () = x ^^^^^^ -Error: This expression has type #('a * 'b) - but an expression was expected of type ('c : value) - The layout of #('a * 'b) is '_representable_layout_485 & '_representable_layout_486 +Error: This expression has type "#('a * 'b)" + but an expression was expected of type "('c : value)" + The layout of #('a * 'b) is '_representable_layout_461 & '_representable_layout_462 because it is an unboxed tuple. But the layout of #('a * 'b) must be a sublayout of value because the type argument of option has layout value. From c9dc09105941812eb444d4260444bb11e5bff1d3 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 9 Sep 2024 17:33:41 +0100 Subject: [PATCH 29/76] Trying to fix magic number tests --- ocaml/build-aux/ocaml_version.m4 | 6 +- ocaml/configure | 3178 +++++++---------- ocaml/configure.ac | 28 +- .../typing-layouts-products/basics_alpha.ml | 12 +- ocaml/utils/misc.ml | 74 +- ocaml/utils/misc.mli | 13 +- tools/flambda_backend_objinfo.ml | 4 +- 7 files changed, 1286 insertions(+), 2029 deletions(-) diff --git a/ocaml/build-aux/ocaml_version.m4 b/ocaml/build-aux/ocaml_version.m4 index 3f8bfa45583..73301ccef84 100644 --- a/ocaml/build-aux/ocaml_version.m4 +++ b/ocaml/build-aux/ocaml_version.m4 @@ -113,10 +113,8 @@ DEFINE_MAGIC_NUMBER([EXEC], EXEC__FORMAT) DEFINE_MAGIC_NUMBER([CMI], [I]) DEFINE_MAGIC_NUMBER([CMO], [O]) DEFINE_MAGIC_NUMBER([CMA], [A]) -DEFINE_MAGIC_NUMBER([CMX_CLAMBDA], [Y]) -DEFINE_MAGIC_NUMBER([CMX_FLAMBDA], [y]) -DEFINE_MAGIC_NUMBER([CMXA_CLAMBDA], [Z]) -DEFINE_MAGIC_NUMBER([CMXA_FLAMBDA], [z]) +DEFINE_MAGIC_NUMBER([CMX], [Y]) +DEFINE_MAGIC_NUMBER([CMXA], [Z]) DEFINE_MAGIC_NUMBER([AST_IMPL], [M]) DEFINE_MAGIC_NUMBER([AST_INTF], [N]) DEFINE_MAGIC_NUMBER([CMXS], [D]) diff --git a/ocaml/configure b/ocaml/configure index b74f8c1e0c1..d72d08164ff 100755 --- a/ocaml/configure +++ b/ocaml/configure @@ -1,11 +1,11 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.72 for OCaml 5.2.0+jst. +# Generated by GNU Autoconf 2.71 for OCaml 5.2.0+jst. # # Report bugs to . # # -# Copyright (C) 1992-1996, 1998-2017, 2020-2023 Free Software Foundation, +# Copyright (C) 1992-1996, 1998-2017, 2020-2021 Free Software Foundation, # Inc. # # @@ -17,6 +17,7 @@ # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh +as_nop=: if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh @@ -25,13 +26,12 @@ then : # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST -else case e in #( - e) case `(set -o) 2>/dev/null` in #( +else $as_nop + case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; -esac ;; esac fi @@ -103,7 +103,7 @@ IFS=$as_save_IFS ;; esac -# We did not find ourselves, most probably we were run as 'sh COMMAND' +# We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 @@ -133,14 +133,15 @@ case $- in # (((( esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed 'exec'. +# out after a failed `exec'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then - as_bourne_compatible="if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 + as_bourne_compatible="as_nop=: +if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: @@ -148,13 +149,12 @@ then : # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST -else case e in #( - e) case \`(set -o) 2>/dev/null\` in #( +else \$as_nop + case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; -esac ;; esac fi " @@ -172,9 +172,8 @@ as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ) then : -else case e in #( - e) exitcode=1; echo positional parameters were not saved. ;; -esac +else \$as_nop + exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 blah=\$(echo \$(echo blah)) @@ -196,15 +195,14 @@ test \$(( 1 + 1 )) = 2 || exit 1" if (eval "$as_required") 2>/dev/null then : as_have_required=yes -else case e in #( - e) as_have_required=no ;; -esac +else $as_nop + as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null then : -else case e in #( - e) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +else $as_nop + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do @@ -237,13 +235,12 @@ IFS=$as_save_IFS if $as_found then : -else case e in #( - e) if { test -f "$SHELL" || test -f "$SHELL.exe"; } && +else $as_nop + if { test -f "$SHELL" || test -f "$SHELL.exe"; } && as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null then : CONFIG_SHELL=$SHELL as_have_required=yes -fi ;; -esac +fi fi @@ -265,7 +262,7 @@ case $- in # (((( esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail -# out after a failed 'exec'. +# out after a failed `exec'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi @@ -285,8 +282,7 @@ $0: manually run the script under such a shell if you do $0: have one." fi exit 1 -fi ;; -esac +fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} @@ -325,6 +321,14 @@ as_fn_exit () as_fn_set_status $1 exit $1 } # as_fn_exit +# as_fn_nop +# --------- +# Do nothing but, unlike ":", preserve the value of $?. +as_fn_nop () +{ + return $? +} +as_nop=as_fn_nop # as_fn_mkdir_p # ------------- @@ -393,12 +397,11 @@ then : { eval $1+=\$2 }' -else case e in #( - e) as_fn_append () +else $as_nop + as_fn_append () { eval $1=\$$1\$2 - } ;; -esac + } fi # as_fn_append # as_fn_arith ARG... @@ -412,14 +415,21 @@ then : { as_val=$(( $* )) }' -else case e in #( - e) as_fn_arith () +else $as_nop + as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` - } ;; -esac + } fi # as_fn_arith +# as_fn_nop +# --------- +# Do nothing but, unlike ":", preserve the value of $?. +as_fn_nop () +{ + return $? +} +as_nop=as_fn_nop # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- @@ -493,8 +503,6 @@ as_cr_alnum=$as_cr_Letters$as_cr_digits /[$]LINENO/= ' <$as_myself | sed ' - t clear - :clear s/[$]LINENO.*/&-/ t lineno b @@ -543,6 +551,7 @@ esac as_echo='printf %s\n' as_echo_n='printf %s' + rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file @@ -554,9 +563,9 @@ if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: - # 1) On MSYS, both 'ln -s file dir' and 'ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; 'ln -s' creates a wrapper executable. - # In both cases, we have to default to 'cp -pR'. + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then @@ -581,12 +590,10 @@ as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. -as_sed_cpp="y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g" -as_tr_cpp="eval sed '$as_sed_cpp'" # deprecated +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. -as_sed_sh="y%*+%pp%;s%[^_$as_cr_alnum]%_%g" -as_tr_sh="eval sed '$as_sed_sh'" # deprecated +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" SHELL=${CONFIG_SHELL-/bin/sh} @@ -1108,7 +1115,7 @@ do ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: '$ac_useropt'" + as_fn_error $? "invalid feature name: \`$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in @@ -1134,7 +1141,7 @@ do ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid feature name: '$ac_useropt'" + as_fn_error $? "invalid feature name: \`$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in @@ -1347,7 +1354,7 @@ do ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: '$ac_useropt'" + as_fn_error $? "invalid package name: \`$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in @@ -1363,7 +1370,7 @@ do ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && - as_fn_error $? "invalid package name: '$ac_useropt'" + as_fn_error $? "invalid package name: \`$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in @@ -1393,8 +1400,8 @@ do | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; - -*) as_fn_error $? "unrecognized option: '$ac_option' -Try '$0 --help' for more information" + -*) as_fn_error $? "unrecognized option: \`$ac_option' +Try \`$0 --help' for more information" ;; *=*) @@ -1402,7 +1409,7 @@ Try '$0 --help' for more information" # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) - as_fn_error $? "invalid variable name: '$ac_envvar'" ;; + as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; @@ -1452,7 +1459,7 @@ do as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done -# There might be people who depend on the old broken behavior: '$host' +# There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias @@ -1520,7 +1527,7 @@ if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi -ac_msg="sources are in $srcdir, but 'cd $srcdir' does not work" +ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` @@ -1548,7 +1555,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -'configure' configures OCaml 5.2.0+jst to adapt to many kinds of systems. +\`configure' configures OCaml 5.2.0+jst to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1562,11 +1569,11 @@ Configuration: --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit - -q, --quiet, --silent do not print 'checking ...' messages + -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] - -C, --config-cache alias for '--cache-file=config.cache' + -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files - --srcdir=DIR find the sources in DIR [configure dir or '..'] + --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX @@ -1574,10 +1581,10 @@ Installation directories: --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] -By default, 'make install' will install all the files in -'$ac_default_prefix/bin', '$ac_default_prefix/lib' etc. You can specify -an installation prefix other than '$ac_default_prefix' using '--prefix', -for instance '--prefix=\$HOME'. +By default, \`make install' will install all the files in +\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify +an installation prefix other than \`$ac_default_prefix' using \`--prefix', +for instance \`--prefix=\$HOME'. For better control, use the options below. @@ -1725,7 +1732,7 @@ Some influential environment variables: User-defined run-time library search path. CPP C preprocessor -Use these variables to override the choices made by 'configure' or to help +Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to . @@ -1794,9 +1801,9 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF OCaml configure 5.2.0+jst -generated by GNU Autoconf 2.72 +generated by GNU Autoconf 2.71 -Copyright (C) 2023 Free Software Foundation, Inc. +Copyright (C) 2021 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF @@ -1835,12 +1842,11 @@ printf "%s\n" "$ac_try_echo"; } >&5 } && test -s conftest.$ac_objext then : ac_retval=0 -else case e in #( - e) printf "%s\n" "$as_me: failed program was:" >&5 +else $as_nop + printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 - ac_retval=1 ;; -esac + ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval @@ -1878,12 +1884,11 @@ printf "%s\n" "$ac_try_echo"; } >&5 } then : ac_retval=0 -else case e in #( - e) printf "%s\n" "$as_me: failed program was:" >&5 +else $as_nop + printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 - ac_retval=1 ;; -esac + ac_retval=1 fi # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would @@ -1907,8 +1912,8 @@ printf %s "checking for $2... " >&6; } if eval test \${$3+y} then : printf %s "(cached) " >&6 -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 #include <$2> @@ -1916,12 +1921,10 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : eval "$3=yes" -else case e in #( - e) eval "$3=no" ;; -esac +else $as_nop + eval "$3=no" fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; -esac +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi eval ac_res=\$$3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 @@ -1941,15 +1944,15 @@ printf %s "checking for $2... " >&6; } if eval test \${$3+y} then : printf %s "(cached) " >&6 -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Define $2 to an innocuous variant, in case declares $2. For example, HP-UX 11i declares gettimeofday. */ #define $2 innocuous_$2 /* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $2 (void); below. */ + which can conflict with char $2 (); below. */ #include #undef $2 @@ -1960,7 +1963,7 @@ else case e in #( #ifdef __cplusplus extern "C" #endif -char $2 (void); +char $2 (); /* The GNU C library defines this for functions which it implements to always fail with ENOSYS. Some functions are actually named something starting with __ and the normal name is an alias. */ @@ -1979,13 +1982,11 @@ _ACEOF if ac_fn_c_try_link "$LINENO" then : eval "$3=yes" -else case e in #( - e) eval "$3=no" ;; -esac +else $as_nop + eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext conftest.$ac_ext ;; -esac + conftest$ac_exeext conftest.$ac_ext fi eval ac_res=\$$3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 @@ -2021,12 +2022,11 @@ printf "%s\n" "$ac_try_echo"; } >&5 } then : ac_retval=0 -else case e in #( - e) printf "%s\n" "$as_me: failed program was:" >&5 +else $as_nop + printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 - ac_retval=1 ;; -esac + ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval @@ -2063,13 +2063,12 @@ printf "%s\n" "$ac_try_echo"; } >&5 test $ac_status = 0; }; } then : ac_retval=0 -else case e in #( - e) printf "%s\n" "$as_me: program exited with status $ac_status" >&5 +else $as_nop + printf "%s\n" "$as_me: program exited with status $ac_status" >&5 printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 - ac_retval=$ac_status ;; -esac + ac_retval=$ac_status fi rm -rf conftest.dSYM conftest_ipa8_conftest.oo eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno @@ -2089,8 +2088,8 @@ printf %s "checking for $2... " >&6; } if eval test \${$3+y} then : printf %s "(cached) " >&6 -else case e in #( - e) eval "$3=no" +else $as_nop + eval "$3=no" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 @@ -2120,14 +2119,12 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : -else case e in #( - e) eval "$3=yes" ;; -esac +else $as_nop + eval "$3=yes" fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; -esac +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi eval ac_res=\$$3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 @@ -2181,19 +2178,18 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_hi=$ac_mid; break -else case e in #( - e) as_fn_arith $ac_mid + 1 && ac_lo=$as_val +else $as_nop + as_fn_arith $ac_mid + 1 && ac_lo=$as_val if test $ac_lo -le $ac_mid; then ac_lo= ac_hi= break fi - as_fn_arith 2 '*' $ac_mid + 1 && ac_mid=$as_val ;; -esac + as_fn_arith 2 '*' $ac_mid + 1 && ac_mid=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext done -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $4 int @@ -2228,23 +2224,20 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_lo=$ac_mid; break -else case e in #( - e) as_fn_arith '(' $ac_mid ')' - 1 && ac_hi=$as_val +else $as_nop + as_fn_arith '(' $ac_mid ')' - 1 && ac_hi=$as_val if test $ac_mid -le $ac_hi; then ac_lo= ac_hi= break fi - as_fn_arith 2 '*' $ac_mid && ac_mid=$as_val ;; -esac + as_fn_arith 2 '*' $ac_mid && ac_mid=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext done -else case e in #( - e) ac_lo= ac_hi= ;; -esac +else $as_nop + ac_lo= ac_hi= fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; -esac +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext # Binary search between lo and hi bounds. @@ -2267,9 +2260,8 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_hi=$ac_mid -else case e in #( - e) as_fn_arith '(' $ac_mid ')' + 1 && ac_lo=$as_val ;; -esac +else $as_nop + as_fn_arith '(' $ac_mid ')' + 1 && ac_lo=$as_val fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext done @@ -2317,9 +2309,8 @@ _ACEOF if ac_fn_c_try_run "$LINENO" then : echo >>conftest.val; read $3 &6; } if eval test \${$3+y} then : printf %s "(cached) " >&6 -else case e in #( - e) as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'` +else $as_nop + as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'` eval ac_save_FLAGS=\$$6 as_fn_append $6 " $5" cat confdefs.h - <<_ACEOF >conftest.$ac_ext @@ -2369,14 +2360,12 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : eval "$3=yes" -else case e in #( - e) eval "$3=no" ;; -esac +else $as_nop + eval "$3=no" fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext eval $6=\$ac_save_FLAGS - ;; -esac + fi eval ac_res=\$$3 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 @@ -2397,8 +2386,8 @@ printf %s "checking for $2.$3... " >&6; } if eval test \${$4+y} then : printf %s "(cached) " >&6 -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $5 int @@ -2414,8 +2403,8 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : eval "$4=yes" -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $5 int @@ -2431,15 +2420,12 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : eval "$4=yes" -else case e in #( - e) eval "$4=no" ;; -esac +else $as_nop + eval "$4=no" fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; -esac +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; -esac +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi eval ac_res=\$$4 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 @@ -2472,7 +2458,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by OCaml $as_me 5.2.0+jst, which was -generated by GNU Autoconf 2.72. Invocation command line was +generated by GNU Autoconf 2.71. Invocation command line was $ $0$ac_configure_args_raw @@ -2718,10 +2704,10 @@ esac printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ - || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} + || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file -See 'config.log' for more details" "$LINENO" 5; } +See \`config.log' for more details" "$LINENO" 5; } fi done @@ -2757,7 +2743,9 @@ struct stat; /* Most of the following tests are stolen from RCS 5.7 src/conf.sh. */ struct buf { int x; }; struct buf * (*rcsopen) (struct buf *, struct stat *, int); -static char *e (char **p, int i) +static char *e (p, i) + char **p; + int i; { return p[i]; } @@ -2771,21 +2759,6 @@ static char *f (char * (*g) (char **, int), char **p, ...) return s; } -/* C89 style stringification. */ -#define noexpand_stringify(a) #a -const char *stringified = noexpand_stringify(arbitrary+token=sequence); - -/* C89 style token pasting. Exercises some of the corner cases that - e.g. old MSVC gets wrong, but not very hard. */ -#define noexpand_concat(a,b) a##b -#define expand_concat(a,b) noexpand_concat(a,b) -extern int vA; -extern int vbee; -#define aye A -#define bee B -int *pvA = &expand_concat(v,aye); -int *pvbee = &noexpand_concat(v,bee); - /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not \xHH hex character constants. These do not provoke an error unfortunately, instead are silently treated @@ -2813,19 +2786,16 @@ ok |= (argc == 0 || f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]); # Test code for whether the C compiler supports C99 (global declarations) ac_c_conftest_c99_globals=' -/* Does the compiler advertise C99 conformance? */ +// Does the compiler advertise C99 conformance? #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L # error "Compiler does not advertise C99 conformance" #endif -// See if C++-style comments work. - #include extern int puts (const char *); extern int printf (const char *, ...); extern int dprintf (int, const char *, ...); extern void *malloc (size_t); -extern void free (void *); // Check varargs macros. These examples are taken from C99 6.10.3.5. // dprintf is used instead of fprintf to avoid needing to declare @@ -2875,6 +2845,7 @@ typedef const char *ccp; static inline int test_restrict (ccp restrict text) { + // See if C++-style comments work. // Iterate through items via the restricted pointer. // Also check for declarations in for loops. for (unsigned int i = 0; *(text+i) != '\''\0'\''; ++i) @@ -2940,8 +2911,6 @@ ac_c_conftest_c99_main=' ia->datasize = 10; for (int i = 0; i < ia->datasize; ++i) ia->data[i] = i * 1.234; - // Work around memory leak warnings. - free (ia); // Check named initializers. struct named_init ni = { @@ -2963,7 +2932,7 @@ ac_c_conftest_c99_main=' # Test code for whether the C compiler supports C11 (global declarations) ac_c_conftest_c11_globals=' -/* Does the compiler advertise C11 conformance? */ +// Does the compiler advertise C11 conformance? #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L # error "Compiler does not advertise C11 conformance" #endif @@ -3155,9 +3124,8 @@ IFS=$as_save_IFS if $as_found then : -else case e in #( - e) as_fn_error $? "cannot find required auxiliary files:$ac_missing_aux_files" "$LINENO" 5 ;; -esac +else $as_nop + as_fn_error $? "cannot find required auxiliary files:$ac_missing_aux_files" "$LINENO" 5 fi @@ -3185,12 +3153,12 @@ for ac_var in $ac_precious_vars; do eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' was set to '$ac_old_val' in the previous run" >&5 -printf "%s\n" "$as_me: error: '$ac_var' was set to '$ac_old_val' in the previous run" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +printf "%s\n" "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' was not set in the previous run" >&5 -printf "%s\n" "$as_me: error: '$ac_var' was not set in the previous run" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 +printf "%s\n" "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) @@ -3199,18 +3167,18 @@ printf "%s\n" "$as_me: error: '$ac_var' was not set in the previous run" >&2;} ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: '$ac_var' has changed since the previous run:" >&5 -printf "%s\n" "$as_me: error: '$ac_var' has changed since the previous run:" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 +printf "%s\n" "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in '$ac_var' since the previous run:" >&5 -printf "%s\n" "$as_me: warning: ignoring whitespace changes in '$ac_var' since the previous run:" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 +printf "%s\n" "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: '$ac_old_val'" >&5 -printf "%s\n" "$as_me: former value: '$ac_old_val'" >&2;} - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: '$ac_new_val'" >&5 -printf "%s\n" "$as_me: current value: '$ac_new_val'" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 +printf "%s\n" "$as_me: former value: \`$ac_old_val'" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 +printf "%s\n" "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. @@ -3226,11 +3194,11 @@ printf "%s\n" "$as_me: current value: '$ac_new_val'" >&2;} fi done if $ac_cache_corrupted; then - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;} - as_fn_error $? "run '${MAKE-make} distclean' and/or 'rm $cache_file' + as_fn_error $? "run \`${MAKE-make} distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## @@ -3330,9 +3298,8 @@ fi if test x"$enable_runtime5" = xyes then : runtime_suffix= -else case e in #( - e) runtime_suffix=4 ;; -esac +else $as_nop + runtime_suffix=4 fi # Check whether --enable-stack_checks was given. @@ -3384,7 +3351,9 @@ CMO_MAGIC_NUMBER=Caml1999O550 CMA_MAGIC_NUMBER=Caml1999A550 +CMX_MAGIC_NUMBER=Caml1999Y550 +CMXA_MAGIC_NUMBER=Caml1999Z550 AST_IMPL_MAGIC_NUMBER=Caml1999M550 @@ -3574,8 +3543,8 @@ then : ac_config_headers="$ac_config_headers runtime/caml/version.h" -else case e in #( - e) ac_config_headers="$ac_config_headers runtime4/caml/m.h" +else $as_nop + ac_config_headers="$ac_config_headers runtime4/caml/m.h" ac_config_headers="$ac_config_headers runtime4/caml/s.h" @@ -3584,8 +3553,7 @@ else case e in #( ac_config_headers="$ac_config_headers runtime4/caml/version.h" - ;; -esac + fi ac_config_files="$ac_config_files compilerlibs/META" @@ -3629,16 +3597,15 @@ printf %s "checking build system type... " >&6; } if test ${ac_cv_build+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_build_alias=$build_alias +else $as_nop + ac_build_alias=$build_alias test "x$ac_build_alias" = x && ac_build_alias=`$SHELL "${ac_aux_dir}config.guess"` test "x$ac_build_alias" = x && as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5 ac_cv_build=`$SHELL "${ac_aux_dir}config.sub" $ac_build_alias` || as_fn_error $? "$SHELL ${ac_aux_dir}config.sub $ac_build_alias failed" "$LINENO" 5 - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 printf "%s\n" "$ac_cv_build" >&6; } @@ -3665,15 +3632,14 @@ printf %s "checking host system type... " >&6; } if test ${ac_cv_host+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test "x$host_alias" = x; then +else $as_nop + if test "x$host_alias" = x; then ac_cv_host=$ac_cv_build else ac_cv_host=`$SHELL "${ac_aux_dir}config.sub" $host_alias` || as_fn_error $? "$SHELL ${ac_aux_dir}config.sub $host_alias failed" "$LINENO" 5 fi - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_host" >&5 printf "%s\n" "$ac_cv_host" >&6; } @@ -3700,15 +3666,14 @@ printf %s "checking target system type... " >&6; } if test ${ac_cv_target+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test "x$target_alias" = x; then +else $as_nop + if test "x$target_alias" = x; then ac_cv_target=$ac_cv_host else ac_cv_target=`$SHELL "${ac_aux_dir}config.sub" $target_alias` || as_fn_error $? "$SHELL ${ac_aux_dir}config.sub $target_alias failed" "$LINENO" 5 fi - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_target" >&5 printf "%s\n" "$ac_cv_target" >&6; } @@ -3787,8 +3752,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_csc+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$csc"; then +else $as_nop + if test -n "$csc"; then ac_cv_prog_csc="$csc" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -3810,8 +3775,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi csc=$ac_cv_prog_csc if test -n "$csc"; then @@ -3856,8 +3820,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_path_dune+y} then : printf %s "(cached) " >&6 -else case e in #( - e) case $dune in +else $as_nop + case $dune in [\\/]* | ?:[\\/]*) ac_cv_path_dune="$dune" # Let the user override the test with a path. ;; @@ -3882,7 +3846,6 @@ done IFS=$as_save_IFS ;; -esac ;; esac fi dune=$ac_cv_path_dune @@ -3914,9 +3877,8 @@ fi if test ${enable_ocamldebug+y} then : enableval=$enable_ocamldebug; -else case e in #( - e) enable_ocamldebug=auto ;; -esac +else $as_nop + enable_ocamldebug=auto fi @@ -3931,9 +3893,8 @@ fi if test ${enable_dependency_generation+y} then : enableval=$enable_dependency_generation; -else case e in #( - e) enable_dependency_generation=auto ;; -esac +else $as_nop + enable_dependency_generation=auto fi @@ -3943,9 +3904,8 @@ fi if test ${enable_instrumented_runtime+y} then : enableval=$enable_instrumented_runtime; -else case e in #( - e) enable_instrumented_runtime=auto ;; -esac +else $as_nop + enable_instrumented_runtime=auto fi @@ -3970,9 +3930,8 @@ fi if test ${enable_tsan+y} then : enableval=$enable_tsan; -else case e in #( - e) enable_tsan=no ;; -esac +else $as_nop + enable_tsan=no fi @@ -4021,9 +3980,8 @@ fi if test ${enable_ocamldoc+y} then : enableval=$enable_ocamldoc; -else case e in #( - e) enable_ocamldoc='auto' ;; -esac +else $as_nop + enable_ocamldoc='auto' fi @@ -4158,9 +4116,8 @@ fi if test ${with_target_bindir+y} then : withval=$with_target_bindir; target_bindir=$withval -else case e in #( - e) target_bindir='' ;; -esac +else $as_nop + target_bindir='' fi @@ -4171,13 +4128,11 @@ then : withval=$with_target_sh; if test x"$withval" = 'xno' then : target_launch_method='exe' -else case e in #( - e) target_launch_method="$withval" ;; -esac +else $as_nop + target_launch_method="$withval" fi -else case e in #( - e) target_launch_method='' ;; -esac +else $as_nop + target_launch_method='' fi @@ -4185,9 +4140,8 @@ fi if test ${enable_stdlib_manpages+y} then : enableval=$enable_stdlib_manpages; -else case e in #( - e) enable_stdlib_manpages='auto' ;; -esac +else $as_nop + enable_stdlib_manpages='auto' fi @@ -4227,9 +4181,8 @@ fi if test ${enable_function_sections+y} then : enableval=$enable_function_sections; -else case e in #( - e) enable_function_sections=auto ;; -esac +else $as_nop + enable_function_sections=auto fi @@ -4286,9 +4239,8 @@ then : if test x"$enable_ocamldebug" = "xyes" then : as_fn_error $? "ocamldebug requires the unix library" "$LINENO" 5 -else case e in #( - e) enable_ocamldebug="no" ;; -esac +else $as_nop + enable_ocamldebug="no" fi fi @@ -4297,14 +4249,12 @@ then : if test x"$enable_ocamldoc" = "xyes" then : as_fn_error $? "ocamldoc requires the unix and str libraries" "$LINENO" 5 -else case e in #( - e) enable_ocamldoc="no" - build_ocamltex=false ;; -esac +else $as_nop + enable_ocamldoc="no" + build_ocamltex=false fi -else case e in #( - e) build_ocamltex=true ;; -esac +else $as_nop + build_ocamltex=true fi if test x"$enable_ocamldoc" = "xno" @@ -4318,15 +4268,14 @@ fi with_ocamldoc="" enable_stdlib_manpages=no build_ocamldoc=false -else case e in #( - e) ocamldoc_target=ocamldoc +else $as_nop + ocamldoc_target=ocamldoc ocamldoc_opt_target=ocamldoc.opt with_ocamldoc=ocamldoc build_ocamldoc=true optional_libraries="$optional_libraries ocamldoc/odoc_info" ac_config_files="$ac_config_files ocamldoc/META" - ;; -esac + fi # Initialization of libtool @@ -4342,8 +4291,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_LD+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$LD"; then +else $as_nop + if test -n "$LD"; then ac_cv_prog_LD="$LD" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -4365,8 +4314,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi LD=$ac_cv_prog_LD if test -n "$LD"; then @@ -4392,8 +4340,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_LD+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_LD"; then +else $as_nop + if test -n "$ac_ct_LD"; then ac_cv_prog_ac_ct_LD="$ac_ct_LD" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -4415,8 +4363,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_LD=$ac_cv_prog_ac_ct_LD if test -n "$ac_ct_LD"; then @@ -4572,8 +4519,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$CC"; then +else $as_nop + if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -4595,8 +4542,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then @@ -4618,8 +4564,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_CC"; then +else $as_nop + if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -4641,8 +4587,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then @@ -4677,8 +4622,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$CC"; then +else $as_nop + if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -4700,8 +4645,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then @@ -4723,8 +4667,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$CC"; then +else $as_nop + if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no @@ -4763,8 +4707,7 @@ if test $ac_prog_rejected = yes; then ac_cv_prog_CC="$as_dir$ac_word${1+' '}$@" fi fi -fi ;; -esac +fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then @@ -4788,8 +4731,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$CC"; then +else $as_nop + if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -4811,8 +4754,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then @@ -4838,8 +4780,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_CC"; then +else $as_nop + if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -4861,8 +4803,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then @@ -4900,8 +4841,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$CC"; then +else $as_nop + if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -4923,8 +4864,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then @@ -4946,8 +4886,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_CC"; then +else $as_nop + if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -4969,8 +4909,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then @@ -4999,10 +4938,10 @@ fi fi -test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} +test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH -See 'config.log' for more details" "$LINENO" 5; } +See \`config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 @@ -5074,8 +5013,8 @@ printf "%s\n" "$ac_try_echo"; } >&5 printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : - # Autoconf-2.13 could set the ac_cv_exeext variable to 'no'. -# So ignore a value of 'no', otherwise this would lead to 'EXEEXT = no' + # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. +# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. @@ -5095,7 +5034,7 @@ do ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not - # safe: cross compilers may not add the suffix if given an '-o' + # safe: cross compilers may not add the suffix if given an `-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. @@ -5106,9 +5045,8 @@ do done test "$ac_cv_exeext" = no && ac_cv_exeext= -else case e in #( - e) ac_file='' ;; -esac +else $as_nop + ac_file='' fi if test -z "$ac_file" then : @@ -5117,14 +5055,13 @@ printf "%s\n" "no" >&6; } printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} +{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "C compiler cannot create executables -See 'config.log' for more details" "$LINENO" 5; } -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -printf "%s\n" "yes" >&6; } ;; -esac +See \`config.log' for more details" "$LINENO" 5; } +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +printf "%s\n" "yes" >&6; } fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 printf %s "checking for C compiler default output file name... " >&6; } @@ -5148,10 +5085,10 @@ printf "%s\n" "$ac_try_echo"; } >&5 printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : - # If both 'conftest.exe' and 'conftest' are 'present' (well, observable) -# catch 'conftest.exe'. For instance with Cygwin, 'ls conftest' will -# work properly (i.e., refer to 'conftest.exe'), while it won't with -# 'rm'. + # If both `conftest.exe' and `conftest' are `present' (well, observable) +# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will +# work properly (i.e., refer to `conftest.exe'), while it won't with +# `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in @@ -5161,12 +5098,11 @@ for ac_file in conftest.exe conftest conftest.*; do * ) break;; esac done -else case e in #( - e) { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} +else $as_nop + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link -See 'config.log' for more details" "$LINENO" 5; } ;; -esac +See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest conftest$ac_cv_exeext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 @@ -5182,8 +5118,6 @@ int main (void) { FILE *f = fopen ("conftest.out", "w"); - if (!f) - return 1; return ferror (f) || fclose (f) != 0; ; @@ -5223,27 +5157,26 @@ printf "%s\n" "$ac_try_echo"; } >&5 if test "$cross_compiling" = maybe; then cross_compiling=yes else - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot run C compiled programs. -If you meant to cross compile, use '--host'. -See 'config.log' for more details" "$LINENO" 5; } +If you meant to cross compile, use \`--host'. +See \`config.log' for more details" "$LINENO" 5; } fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 printf "%s\n" "$cross_compiling" >&6; } -rm -f conftest.$ac_ext conftest$ac_cv_exeext \ - conftest.o conftest.obj conftest.out +rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out ac_clean_files=$ac_clean_files_save { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 printf %s "checking for suffix of object files... " >&6; } if test ${ac_cv_objext+y} then : printf %s "(cached) " >&6 -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int @@ -5275,18 +5208,16 @@ then : break;; esac done -else case e in #( - e) printf "%s\n" "$as_me: failed program was:" >&5 +else $as_nop + printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 -{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} +{ { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile -See 'config.log' for more details" "$LINENO" 5; } ;; -esac +See \`config.log' for more details" "$LINENO" 5; } fi -rm -f conftest.$ac_cv_objext conftest.$ac_ext ;; -esac +rm -f conftest.$ac_cv_objext conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 printf "%s\n" "$ac_cv_objext" >&6; } @@ -5297,8 +5228,8 @@ printf %s "checking whether the compiler supports GNU C... " >&6; } if test ${ac_cv_c_compiler_gnu+y} then : printf %s "(cached) " >&6 -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int @@ -5315,14 +5246,12 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_compiler_gnu=yes -else case e in #( - e) ac_compiler_gnu=no ;; -esac +else $as_nop + ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; } @@ -5340,8 +5269,8 @@ printf %s "checking whether $CC accepts -g... " >&6; } if test ${ac_cv_prog_cc_g+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_save_c_werror_flag=$ac_c_werror_flag +else $as_nop + ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" @@ -5359,8 +5288,8 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_g=yes -else case e in #( - e) CFLAGS="" +else $as_nop + CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -5375,8 +5304,8 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : -else case e in #( - e) ac_c_werror_flag=$ac_save_c_werror_flag +else $as_nop + ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -5393,15 +5322,12 @@ if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_g=yes fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; -esac +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; -esac +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - ac_c_werror_flag=$ac_save_c_werror_flag ;; -esac + ac_c_werror_flag=$ac_save_c_werror_flag fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 printf "%s\n" "$ac_cv_prog_cc_g" >&6; } @@ -5428,8 +5354,8 @@ printf %s "checking for $CC option to enable C11 features... " >&6; } if test ${ac_cv_prog_cc_c11+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_cv_prog_cc_c11=no +else $as_nop + ac_cv_prog_cc_c11=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -5446,28 +5372,25 @@ rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c11" != "xno" && break done rm -f conftest.$ac_ext -CC=$ac_save_CC ;; -esac +CC=$ac_save_CC fi if test "x$ac_cv_prog_cc_c11" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } -else case e in #( - e) if test "x$ac_cv_prog_cc_c11" = x +else $as_nop + if test "x$ac_cv_prog_cc_c11" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5 printf "%s\n" "$ac_cv_prog_cc_c11" >&6; } - CC="$CC $ac_cv_prog_cc_c11" ;; -esac + CC="$CC $ac_cv_prog_cc_c11" fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11 - ac_prog_cc_stdc=c11 ;; -esac + ac_prog_cc_stdc=c11 fi fi if test x$ac_prog_cc_stdc = xno @@ -5477,8 +5400,8 @@ printf %s "checking for $CC option to enable C99 features... " >&6; } if test ${ac_cv_prog_cc_c99+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_cv_prog_cc_c99=no +else $as_nop + ac_cv_prog_cc_c99=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -5495,28 +5418,25 @@ rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c99" != "xno" && break done rm -f conftest.$ac_ext -CC=$ac_save_CC ;; -esac +CC=$ac_save_CC fi if test "x$ac_cv_prog_cc_c99" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } -else case e in #( - e) if test "x$ac_cv_prog_cc_c99" = x +else $as_nop + if test "x$ac_cv_prog_cc_c99" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 printf "%s\n" "$ac_cv_prog_cc_c99" >&6; } - CC="$CC $ac_cv_prog_cc_c99" ;; -esac + CC="$CC $ac_cv_prog_cc_c99" fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 - ac_prog_cc_stdc=c99 ;; -esac + ac_prog_cc_stdc=c99 fi fi if test x$ac_prog_cc_stdc = xno @@ -5526,8 +5446,8 @@ printf %s "checking for $CC option to enable C89 features... " >&6; } if test ${ac_cv_prog_cc_c89+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_cv_prog_cc_c89=no +else $as_nop + ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -5544,28 +5464,25 @@ rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext -CC=$ac_save_CC ;; -esac +CC=$ac_save_CC fi if test "x$ac_cv_prog_cc_c89" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } -else case e in #( - e) if test "x$ac_cv_prog_cc_c89" = x +else $as_nop + if test "x$ac_cv_prog_cc_c89" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 printf "%s\n" "$ac_cv_prog_cc_c89" >&6; } - CC="$CC $ac_cv_prog_cc_c89" ;; -esac + CC="$CC $ac_cv_prog_cc_c89" fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 - ac_prog_cc_stdc=c89 ;; -esac + ac_prog_cc_stdc=c89 fi fi @@ -5580,8 +5497,8 @@ printf %s "checking for a sed that does not truncate output... " >&6; } if test ${ac_cv_path_SED+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_script=s/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb/ +else $as_nop + ac_script=s/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa/bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb/ for ac_i in 1 2 3 4 5 6 7; do ac_script="$ac_script$as_nl$ac_script" done @@ -5606,10 +5523,9 @@ do as_fn_executable_p "$ac_path_SED" || continue # Check for GNU ac_path_SED and select it if it is found. # Check for GNU $ac_path_SED -case `"$ac_path_SED" --version 2>&1` in #( +case `"$ac_path_SED" --version 2>&1` in *GNU*) ac_cv_path_SED="$ac_path_SED" ac_path_SED_found=:;; -#( *) ac_count=0 printf %s 0123456789 >"conftest.in" @@ -5644,8 +5560,7 @@ IFS=$as_save_IFS else ac_cv_path_SED=$SED fi - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_SED" >&5 printf "%s\n" "$ac_cv_path_SED" >&6; } @@ -5670,8 +5585,8 @@ printf %s "checking for grep that handles long lines and -e... " >&6; } if test ${ac_cv_path_GREP+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -z "$GREP"; then +else $as_nop + if test -z "$GREP"; then ac_path_GREP_found=false # Loop through the user's path and test for each of PROGNAME-LIST as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -5690,10 +5605,9 @@ do as_fn_executable_p "$ac_path_GREP" || continue # Check for GNU ac_path_GREP and select it if it is found. # Check for GNU $ac_path_GREP -case `"$ac_path_GREP" --version 2>&1` in #( +case `"$ac_path_GREP" --version 2>&1` in *GNU*) ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; -#( *) ac_count=0 printf %s 0123456789 >"conftest.in" @@ -5728,8 +5642,7 @@ IFS=$as_save_IFS else ac_cv_path_GREP=$GREP fi - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 printf "%s\n" "$ac_cv_path_GREP" >&6; } @@ -5741,8 +5654,8 @@ printf %s "checking for egrep... " >&6; } if test ${ac_cv_path_EGREP+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 +else $as_nop + if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 then ac_cv_path_EGREP="$GREP -E" else if test -z "$EGREP"; then @@ -5764,10 +5677,9 @@ do as_fn_executable_p "$ac_path_EGREP" || continue # Check for GNU ac_path_EGREP and select it if it is found. # Check for GNU $ac_path_EGREP -case `"$ac_path_EGREP" --version 2>&1` in #( +case `"$ac_path_EGREP" --version 2>&1` in *GNU*) ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; -#( *) ac_count=0 printf %s 0123456789 >"conftest.in" @@ -5803,23 +5715,20 @@ else ac_cv_path_EGREP=$EGREP fi - fi ;; -esac + fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 printf "%s\n" "$ac_cv_path_EGREP" >&6; } EGREP="$ac_cv_path_EGREP" - EGREP_TRADITIONAL=$EGREP - ac_cv_path_EGREP_TRADITIONAL=$EGREP { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for fgrep" >&5 printf %s "checking for fgrep... " >&6; } if test ${ac_cv_path_FGREP+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if echo 'ab*c' | $GREP -F 'ab*c' >/dev/null 2>&1 +else $as_nop + if echo 'ab*c' | $GREP -F 'ab*c' >/dev/null 2>&1 then ac_cv_path_FGREP="$GREP -F" else if test -z "$FGREP"; then @@ -5841,10 +5750,9 @@ do as_fn_executable_p "$ac_path_FGREP" || continue # Check for GNU ac_path_FGREP and select it if it is found. # Check for GNU $ac_path_FGREP -case `"$ac_path_FGREP" --version 2>&1` in #( +case `"$ac_path_FGREP" --version 2>&1` in *GNU*) ac_cv_path_FGREP="$ac_path_FGREP" ac_path_FGREP_found=:;; -#( *) ac_count=0 printf %s 0123456789 >"conftest.in" @@ -5880,8 +5788,7 @@ else ac_cv_path_FGREP=$FGREP fi - fi ;; -esac + fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_FGREP" >&5 printf "%s\n" "$ac_cv_path_FGREP" >&6; } @@ -5912,9 +5819,8 @@ test -z "$GREP" && GREP=grep if test ${with_gnu_ld+y} then : withval=$with_gnu_ld; test no = "$withval" || with_gnu_ld=yes -else case e in #( - e) with_gnu_ld=no ;; -esac +else $as_nop + with_gnu_ld=no fi ac_prog=ld @@ -5959,8 +5865,8 @@ fi if test ${lt_cv_path_LD+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -z "$LD"; then +else $as_nop + if test -z "$LD"; then lt_save_ifs=$IFS; IFS=$PATH_SEPARATOR for ac_dir in $PATH; do IFS=$lt_save_ifs @@ -5983,8 +5889,7 @@ else case e in #( IFS=$lt_save_ifs else lt_cv_path_LD=$LD # Let the user override the test with a path. -fi ;; -esac +fi fi LD=$lt_cv_path_LD @@ -6001,8 +5906,8 @@ printf %s "checking if the linker ($LD) is GNU ld... " >&6; } if test ${lt_cv_prog_gnu_ld+y} then : printf %s "(cached) " >&6 -else case e in #( - e) # I'd rather use --version here, but apparently some GNU lds only accept -v. +else $as_nop + # I'd rather use --version here, but apparently some GNU lds only accept -v. case `$LD -v 2>&1 &1 &5 @@ -6030,8 +5934,8 @@ printf %s "checking for BSD- or MS-compatible name lister (nm)... " >&6; } if test ${lt_cv_path_NM+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$NM"; then +else $as_nop + if test -n "$NM"; then # Let the user override the test. lt_cv_path_NM=$NM else @@ -6078,8 +5982,7 @@ else IFS=$lt_save_ifs done : ${lt_cv_path_NM=no} -fi ;; -esac +fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_path_NM" >&5 printf "%s\n" "$lt_cv_path_NM" >&6; } @@ -6100,8 +6003,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_DUMPBIN+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$DUMPBIN"; then +else $as_nop + if test -n "$DUMPBIN"; then ac_cv_prog_DUMPBIN="$DUMPBIN" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -6123,8 +6026,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi DUMPBIN=$ac_cv_prog_DUMPBIN if test -n "$DUMPBIN"; then @@ -6150,8 +6052,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_DUMPBIN+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_DUMPBIN"; then +else $as_nop + if test -n "$ac_ct_DUMPBIN"; then ac_cv_prog_ac_ct_DUMPBIN="$ac_ct_DUMPBIN" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -6173,8 +6075,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_DUMPBIN=$ac_cv_prog_ac_ct_DUMPBIN if test -n "$ac_ct_DUMPBIN"; then @@ -6228,8 +6129,8 @@ printf %s "checking the name lister ($NM) interface... " >&6; } if test ${lt_cv_nm_interface+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_nm_interface="BSD nm" +else $as_nop + lt_cv_nm_interface="BSD nm" echo "int some_variable = 0;" > conftest.$ac_ext (eval echo "\"\$as_me:$LINENO: $ac_compile\"" >&5) (eval "$ac_compile" 2>conftest.err) @@ -6242,8 +6143,7 @@ else case e in #( if $GREP 'External.*some_variable' conftest.out > /dev/null; then lt_cv_nm_interface="MS dumpbin" fi - rm -f conftest* ;; -esac + rm -f conftest* fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_nm_interface" >&5 printf "%s\n" "$lt_cv_nm_interface" >&6; } @@ -6265,8 +6165,8 @@ printf %s "checking the maximum length of command line arguments... " >&6; } if test ${lt_cv_sys_max_cmd_len+y} then : printf %s "(cached) " >&6 -else case e in #( - e) i=0 +else $as_nop + i=0 teststring=ABCD case $build_os in @@ -6388,8 +6288,7 @@ else case e in #( fi ;; esac - ;; -esac + fi if test -n "$lt_cv_sys_max_cmd_len"; then @@ -6446,8 +6345,8 @@ printf %s "checking how to convert $build file names to $host format... " >&6; } if test ${lt_cv_to_host_file_cmd+y} then : printf %s "(cached) " >&6 -else case e in #( - e) case $host in +else $as_nop + case $host in *-*-mingw* ) case $build in *-*-mingw* ) # actually msys @@ -6478,8 +6377,7 @@ else case e in #( lt_cv_to_host_file_cmd=func_convert_file_noop ;; esac - ;; -esac + fi to_host_file_cmd=$lt_cv_to_host_file_cmd @@ -6495,8 +6393,8 @@ printf %s "checking how to convert $build file names to toolchain format... " >& if test ${lt_cv_to_tool_file_cmd+y} then : printf %s "(cached) " >&6 -else case e in #( - e) #assume ordinary cross tools, or native build. +else $as_nop + #assume ordinary cross tools, or native build. lt_cv_to_tool_file_cmd=func_convert_file_noop case $host in *-*-mingw* ) @@ -6507,8 +6405,7 @@ case $host in esac ;; esac - ;; -esac + fi to_tool_file_cmd=$lt_cv_to_tool_file_cmd @@ -6524,9 +6421,8 @@ printf %s "checking for $LD option to reload object files... " >&6; } if test ${lt_cv_ld_reload_flag+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_ld_reload_flag='-r' ;; -esac +else $as_nop + lt_cv_ld_reload_flag='-r' fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ld_reload_flag" >&5 printf "%s\n" "$lt_cv_ld_reload_flag" >&6; } @@ -6567,8 +6463,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_OBJDUMP+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$OBJDUMP"; then +else $as_nop + if test -n "$OBJDUMP"; then ac_cv_prog_OBJDUMP="$OBJDUMP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -6590,8 +6486,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi OBJDUMP=$ac_cv_prog_OBJDUMP if test -n "$OBJDUMP"; then @@ -6613,8 +6508,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_OBJDUMP+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_OBJDUMP"; then +else $as_nop + if test -n "$ac_ct_OBJDUMP"; then ac_cv_prog_ac_ct_OBJDUMP="$ac_ct_OBJDUMP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -6636,8 +6531,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_OBJDUMP=$ac_cv_prog_ac_ct_OBJDUMP if test -n "$ac_ct_OBJDUMP"; then @@ -6678,8 +6572,8 @@ printf %s "checking how to recognize dependent libraries... " >&6; } if test ${lt_cv_deplibs_check_method+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_file_magic_cmd='$MAGIC_CMD' +else $as_nop + lt_cv_file_magic_cmd='$MAGIC_CMD' lt_cv_file_magic_test_file= lt_cv_deplibs_check_method='unknown' # Need to set the preceding variable on all platforms that support @@ -6872,8 +6766,7 @@ os2*) lt_cv_deplibs_check_method=pass_all ;; esac - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_deplibs_check_method" >&5 printf "%s\n" "$lt_cv_deplibs_check_method" >&6; } @@ -6925,8 +6818,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_DLLTOOL+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$DLLTOOL"; then +else $as_nop + if test -n "$DLLTOOL"; then ac_cv_prog_DLLTOOL="$DLLTOOL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -6948,8 +6841,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi DLLTOOL=$ac_cv_prog_DLLTOOL if test -n "$DLLTOOL"; then @@ -6971,8 +6863,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_DLLTOOL+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_DLLTOOL"; then +else $as_nop + if test -n "$ac_ct_DLLTOOL"; then ac_cv_prog_ac_ct_DLLTOOL="$ac_ct_DLLTOOL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -6994,8 +6886,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_DLLTOOL=$ac_cv_prog_ac_ct_DLLTOOL if test -n "$ac_ct_DLLTOOL"; then @@ -7037,8 +6928,8 @@ printf %s "checking how to associate runtime and link libraries... " >&6; } if test ${lt_cv_sharedlib_from_linklib_cmd+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_sharedlib_from_linklib_cmd='unknown' +else $as_nop + lt_cv_sharedlib_from_linklib_cmd='unknown' case $host_os in cygwin* | mingw* | pw32* | cegcc*) @@ -7058,8 +6949,7 @@ cygwin* | mingw* | pw32* | cegcc*) lt_cv_sharedlib_from_linklib_cmd=$ECHO ;; esac - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_sharedlib_from_linklib_cmd" >&5 printf "%s\n" "$lt_cv_sharedlib_from_linklib_cmd" >&6; } @@ -7083,8 +6973,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_AR+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$AR"; then +else $as_nop + if test -n "$AR"; then ac_cv_prog_AR="$AR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -7106,8 +6996,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi AR=$ac_cv_prog_AR if test -n "$AR"; then @@ -7133,8 +7022,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_AR+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_AR"; then +else $as_nop + if test -n "$ac_ct_AR"; then ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -7156,8 +7045,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_AR=$ac_cv_prog_ac_ct_AR if test -n "$ac_ct_AR"; then @@ -7203,8 +7091,8 @@ printf %s "checking for archiver @FILE support... " >&6; } if test ${lt_cv_ar_at_file+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_ar_at_file=no +else $as_nop + lt_cv_ar_at_file=no cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -7241,8 +7129,7 @@ then : fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ar_at_file" >&5 printf "%s\n" "$lt_cv_ar_at_file" >&6; } @@ -7267,8 +7154,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_STRIP+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$STRIP"; then +else $as_nop + if test -n "$STRIP"; then ac_cv_prog_STRIP="$STRIP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -7290,8 +7177,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi STRIP=$ac_cv_prog_STRIP if test -n "$STRIP"; then @@ -7313,8 +7199,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_STRIP+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_STRIP"; then +else $as_nop + if test -n "$ac_ct_STRIP"; then ac_cv_prog_ac_ct_STRIP="$ac_ct_STRIP" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -7336,8 +7222,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_STRIP=$ac_cv_prog_ac_ct_STRIP if test -n "$ac_ct_STRIP"; then @@ -7378,8 +7263,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_RANLIB+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$RANLIB"; then +else $as_nop + if test -n "$RANLIB"; then ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -7401,8 +7286,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi RANLIB=$ac_cv_prog_RANLIB if test -n "$RANLIB"; then @@ -7424,8 +7308,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_RANLIB+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_RANLIB"; then +else $as_nop + if test -n "$ac_ct_RANLIB"; then ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -7447,8 +7331,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB if test -n "$ac_ct_RANLIB"; then @@ -7534,8 +7417,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_AWK+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$AWK"; then +else $as_nop + if test -n "$AWK"; then ac_cv_prog_AWK="$AWK" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -7557,8 +7440,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi AWK=$ac_cv_prog_AWK if test -n "$AWK"; then @@ -7607,8 +7489,8 @@ printf %s "checking command to parse $NM output from $compiler object... " >&6; if test ${lt_cv_sys_global_symbol_pipe+y} then : printf %s "(cached) " >&6 -else case e in #( - e) +else $as_nop + # These are sane defaults that work on at least a few old systems. # [They come from Ultrix. What could be older than Ultrix?!! ;)] @@ -7863,8 +7745,7 @@ _LT_EOF lt_cv_sys_global_symbol_pipe= fi done - ;; -esac + fi if test -z "$lt_cv_sys_global_symbol_pipe"; then @@ -7928,9 +7809,8 @@ printf %s "checking for sysroot... " >&6; } if test ${with_sysroot+y} then : withval=$with_sysroot; -else case e in #( - e) with_sysroot=no ;; -esac +else $as_nop + with_sysroot=no fi @@ -7965,8 +7845,8 @@ printf %s "checking for a working dd... " >&6; } if test ${ac_cv_path_lt_DD+y} then : printf %s "(cached) " >&6 -else case e in #( - e) printf 0123456789abcdef0123456789abcdef >conftest.i +else $as_nop + printf 0123456789abcdef0123456789abcdef >conftest.i cat conftest.i conftest.i >conftest2.i : ${lt_DD:=$DD} if test -z "$lt_DD"; then @@ -8002,8 +7882,7 @@ else ac_cv_path_lt_DD=$lt_DD fi -rm -f conftest.i conftest2.i conftest.out ;; -esac +rm -f conftest.i conftest2.i conftest.out fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_lt_DD" >&5 printf "%s\n" "$ac_cv_path_lt_DD" >&6; } @@ -8014,8 +7893,8 @@ printf %s "checking how to truncate binary pipes... " >&6; } if test ${lt_cv_truncate_bin+y} then : printf %s "(cached) " >&6 -else case e in #( - e) printf 0123456789abcdef0123456789abcdef >conftest.i +else $as_nop + printf 0123456789abcdef0123456789abcdef >conftest.i cat conftest.i conftest.i >conftest2.i lt_cv_truncate_bin= if "$ac_cv_path_lt_DD" bs=32 count=1 conftest.out 2>/dev/null; then @@ -8023,8 +7902,7 @@ if "$ac_cv_path_lt_DD" bs=32 count=1 conftest.out 2>/dev/null; the && lt_cv_truncate_bin="$ac_cv_path_lt_DD bs=4096 count=1" fi rm -f conftest.i conftest2.i conftest.out -test -z "$lt_cv_truncate_bin" && lt_cv_truncate_bin="$SED -e 4q" ;; -esac +test -z "$lt_cv_truncate_bin" && lt_cv_truncate_bin="$SED -e 4q" fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_truncate_bin" >&5 printf "%s\n" "$lt_cv_truncate_bin" >&6; } @@ -8234,8 +8112,8 @@ printf %s "checking whether the C compiler needs -belf... " >&6; } if test ${lt_cv_cc_needs_belf+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_ext=c +else $as_nop + ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' @@ -8255,9 +8133,8 @@ _ACEOF if ac_fn_c_try_link "$LINENO" then : lt_cv_cc_needs_belf=yes -else case e in #( - e) lt_cv_cc_needs_belf=no ;; -esac +else $as_nop + lt_cv_cc_needs_belf=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext @@ -8266,8 +8143,7 @@ ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_cc_needs_belf" >&5 printf "%s\n" "$lt_cv_cc_needs_belf" >&6; } @@ -8325,8 +8201,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_MANIFEST_TOOL+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$MANIFEST_TOOL"; then +else $as_nop + if test -n "$MANIFEST_TOOL"; then ac_cv_prog_MANIFEST_TOOL="$MANIFEST_TOOL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -8348,8 +8224,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi MANIFEST_TOOL=$ac_cv_prog_MANIFEST_TOOL if test -n "$MANIFEST_TOOL"; then @@ -8371,8 +8246,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_MANIFEST_TOOL+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_MANIFEST_TOOL"; then +else $as_nop + if test -n "$ac_ct_MANIFEST_TOOL"; then ac_cv_prog_ac_ct_MANIFEST_TOOL="$ac_ct_MANIFEST_TOOL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -8394,8 +8269,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_MANIFEST_TOOL=$ac_cv_prog_ac_ct_MANIFEST_TOOL if test -n "$ac_ct_MANIFEST_TOOL"; then @@ -8427,16 +8301,15 @@ printf %s "checking if $MANIFEST_TOOL is a manifest tool... " >&6; } if test ${lt_cv_path_mainfest_tool+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_path_mainfest_tool=no +else $as_nop + lt_cv_path_mainfest_tool=no echo "$as_me:$LINENO: $MANIFEST_TOOL '-?'" >&5 $MANIFEST_TOOL '-?' 2>conftest.err > conftest.out cat conftest.err >&5 if $GREP 'Manifest Tool' conftest.out > /dev/null; then lt_cv_path_mainfest_tool=yes fi - rm -f conftest* ;; -esac + rm -f conftest* fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_path_mainfest_tool" >&5 printf "%s\n" "$lt_cv_path_mainfest_tool" >&6; } @@ -8459,8 +8332,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_DSYMUTIL+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$DSYMUTIL"; then +else $as_nop + if test -n "$DSYMUTIL"; then ac_cv_prog_DSYMUTIL="$DSYMUTIL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -8482,8 +8355,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi DSYMUTIL=$ac_cv_prog_DSYMUTIL if test -n "$DSYMUTIL"; then @@ -8505,8 +8377,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_DSYMUTIL+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_DSYMUTIL"; then +else $as_nop + if test -n "$ac_ct_DSYMUTIL"; then ac_cv_prog_ac_ct_DSYMUTIL="$ac_ct_DSYMUTIL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -8528,8 +8400,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_DSYMUTIL=$ac_cv_prog_ac_ct_DSYMUTIL if test -n "$ac_ct_DSYMUTIL"; then @@ -8563,8 +8434,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_NMEDIT+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$NMEDIT"; then +else $as_nop + if test -n "$NMEDIT"; then ac_cv_prog_NMEDIT="$NMEDIT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -8586,8 +8457,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi NMEDIT=$ac_cv_prog_NMEDIT if test -n "$NMEDIT"; then @@ -8609,8 +8479,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_NMEDIT+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_NMEDIT"; then +else $as_nop + if test -n "$ac_ct_NMEDIT"; then ac_cv_prog_ac_ct_NMEDIT="$ac_ct_NMEDIT" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -8632,8 +8502,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_NMEDIT=$ac_cv_prog_ac_ct_NMEDIT if test -n "$ac_ct_NMEDIT"; then @@ -8667,8 +8536,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_LIPO+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$LIPO"; then +else $as_nop + if test -n "$LIPO"; then ac_cv_prog_LIPO="$LIPO" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -8690,8 +8559,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi LIPO=$ac_cv_prog_LIPO if test -n "$LIPO"; then @@ -8713,8 +8581,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_LIPO+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_LIPO"; then +else $as_nop + if test -n "$ac_ct_LIPO"; then ac_cv_prog_ac_ct_LIPO="$ac_ct_LIPO" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -8736,8 +8604,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_LIPO=$ac_cv_prog_ac_ct_LIPO if test -n "$ac_ct_LIPO"; then @@ -8771,8 +8638,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_OTOOL+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$OTOOL"; then +else $as_nop + if test -n "$OTOOL"; then ac_cv_prog_OTOOL="$OTOOL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -8794,8 +8661,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi OTOOL=$ac_cv_prog_OTOOL if test -n "$OTOOL"; then @@ -8817,8 +8683,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_OTOOL+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_OTOOL"; then +else $as_nop + if test -n "$ac_ct_OTOOL"; then ac_cv_prog_ac_ct_OTOOL="$ac_ct_OTOOL" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -8840,8 +8706,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_OTOOL=$ac_cv_prog_ac_ct_OTOOL if test -n "$ac_ct_OTOOL"; then @@ -8875,8 +8740,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_OTOOL64+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$OTOOL64"; then +else $as_nop + if test -n "$OTOOL64"; then ac_cv_prog_OTOOL64="$OTOOL64" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -8898,8 +8763,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi OTOOL64=$ac_cv_prog_OTOOL64 if test -n "$OTOOL64"; then @@ -8921,8 +8785,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_OTOOL64+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_OTOOL64"; then +else $as_nop + if test -n "$ac_ct_OTOOL64"; then ac_cv_prog_ac_ct_OTOOL64="$ac_ct_OTOOL64" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -8944,8 +8808,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_OTOOL64=$ac_cv_prog_ac_ct_OTOOL64 if test -n "$ac_ct_OTOOL64"; then @@ -9002,8 +8865,8 @@ printf %s "checking for -single_module linker flag... " >&6; } if test ${lt_cv_apple_cc_single_mod+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_apple_cc_single_mod=no +else $as_nop + lt_cv_apple_cc_single_mod=no if test -z "$LT_MULTI_MODULE"; then # By default we will add the -single_module flag. You can override # by either setting the environment variable LT_MULTI_MODULE @@ -9029,8 +8892,7 @@ else case e in #( fi rm -rf libconftest.dylib* rm -f conftest.* - fi ;; -esac + fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_apple_cc_single_mod" >&5 printf "%s\n" "$lt_cv_apple_cc_single_mod" >&6; } @@ -9040,8 +8902,8 @@ printf %s "checking for -exported_symbols_list linker flag... " >&6; } if test ${lt_cv_ld_exported_symbols_list+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_ld_exported_symbols_list=no +else $as_nop + lt_cv_ld_exported_symbols_list=no save_LDFLAGS=$LDFLAGS echo "_main" > conftest.sym LDFLAGS="$LDFLAGS -Wl,-exported_symbols_list,conftest.sym" @@ -9059,15 +8921,13 @@ _ACEOF if ac_fn_c_try_link "$LINENO" then : lt_cv_ld_exported_symbols_list=yes -else case e in #( - e) lt_cv_ld_exported_symbols_list=no ;; -esac +else $as_nop + lt_cv_ld_exported_symbols_list=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$save_LDFLAGS - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ld_exported_symbols_list" >&5 printf "%s\n" "$lt_cv_ld_exported_symbols_list" >&6; } @@ -9077,8 +8937,8 @@ printf %s "checking for -force_load linker flag... " >&6; } if test ${lt_cv_ld_force_load+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_ld_force_load=no +else $as_nop + lt_cv_ld_force_load=no cat > conftest.c << _LT_EOF int forced_loaded() { return 2;} _LT_EOF @@ -9103,8 +8963,7 @@ _LT_EOF fi rm -f conftest.err libconftest.a conftest conftest.c rm -rf conftest.dSYM - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_ld_force_load" >&5 printf "%s\n" "$lt_cv_ld_force_load" >&6; } @@ -9249,9 +9108,8 @@ then : IFS=$lt_save_ifs ;; esac -else case e in #( - e) enable_shared=yes ;; -esac +else $as_nop + enable_shared=yes fi @@ -9282,9 +9140,8 @@ then : IFS=$lt_save_ifs ;; esac -else case e in #( - e) enable_static=yes ;; -esac +else $as_nop + enable_static=yes fi @@ -9315,9 +9172,8 @@ then : IFS=$lt_save_ifs ;; esac -else case e in #( - e) pic_mode=default ;; -esac +else $as_nop + pic_mode=default fi @@ -9347,9 +9203,8 @@ then : IFS=$lt_save_ifs ;; esac -else case e in #( - e) enable_fast_install=yes ;; -esac +else $as_nop + enable_fast_install=yes fi @@ -9376,17 +9231,15 @@ then : ;; esac lt_cv_with_aix_soname=$with_aix_soname -else case e in #( - e) if test ${lt_cv_with_aix_soname+y} +else $as_nop + if test ${lt_cv_with_aix_soname+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_with_aix_soname=aix ;; -esac +else $as_nop + lt_cv_with_aix_soname=aix fi - with_aix_soname=$lt_cv_with_aix_soname ;; -esac + with_aix_soname=$lt_cv_with_aix_soname fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $with_aix_soname" >&5 @@ -9477,8 +9330,8 @@ printf %s "checking for objdir... " >&6; } if test ${lt_cv_objdir+y} then : printf %s "(cached) " >&6 -else case e in #( - e) rm -f .libs 2>/dev/null +else $as_nop + rm -f .libs 2>/dev/null mkdir .libs 2>/dev/null if test -d .libs; then lt_cv_objdir=.libs @@ -9486,8 +9339,7 @@ else # MS-DOS does not allow filenames that begin with a dot. lt_cv_objdir=_libs fi -rmdir .libs 2>/dev/null ;; -esac +rmdir .libs 2>/dev/null fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_objdir" >&5 printf "%s\n" "$lt_cv_objdir" >&6; } @@ -9548,8 +9400,8 @@ printf %s "checking for ${ac_tool_prefix}file... " >&6; } if test ${lt_cv_path_MAGIC_CMD+y} then : printf %s "(cached) " >&6 -else case e in #( - e) case $MAGIC_CMD in +else $as_nop + case $MAGIC_CMD in [\\/*] | ?:[\\/]*) lt_cv_path_MAGIC_CMD=$MAGIC_CMD # Let the user override the test with a path. ;; @@ -9592,7 +9444,6 @@ _LT_EOF IFS=$lt_save_ifs MAGIC_CMD=$lt_save_MAGIC_CMD ;; -esac ;; esac fi @@ -9616,8 +9467,8 @@ printf %s "checking for file... " >&6; } if test ${lt_cv_path_MAGIC_CMD+y} then : printf %s "(cached) " >&6 -else case e in #( - e) case $MAGIC_CMD in +else $as_nop + case $MAGIC_CMD in [\\/*] | ?:[\\/]*) lt_cv_path_MAGIC_CMD=$MAGIC_CMD # Let the user override the test with a path. ;; @@ -9660,7 +9511,6 @@ _LT_EOF IFS=$lt_save_ifs MAGIC_CMD=$lt_save_MAGIC_CMD ;; -esac ;; esac fi @@ -9760,8 +9610,8 @@ printf %s "checking if $compiler supports -fno-rtti -fno-exceptions... " >&6; } if test ${lt_cv_prog_compiler_rtti_exceptions+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_prog_compiler_rtti_exceptions=no +else $as_nop + lt_cv_prog_compiler_rtti_exceptions=no ac_outfile=conftest.$ac_objext echo "$lt_simple_compile_test_code" > conftest.$ac_ext lt_compiler_flag="-fno-rtti -fno-exceptions" ## exclude from sc_useless_quotes_in_assignment @@ -9789,8 +9639,7 @@ else case e in #( fi fi $RM conftest* - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_rtti_exceptions" >&5 printf "%s\n" "$lt_cv_prog_compiler_rtti_exceptions" >&6; } @@ -10155,9 +10004,8 @@ printf %s "checking for $compiler option to produce PIC... " >&6; } if test ${lt_cv_prog_compiler_pic+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_prog_compiler_pic=$lt_prog_compiler_pic ;; -esac +else $as_nop + lt_cv_prog_compiler_pic=$lt_prog_compiler_pic fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic" >&5 printf "%s\n" "$lt_cv_prog_compiler_pic" >&6; } @@ -10172,8 +10020,8 @@ printf %s "checking if $compiler PIC flag $lt_prog_compiler_pic works... " >&6; if test ${lt_cv_prog_compiler_pic_works+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_prog_compiler_pic_works=no +else $as_nop + lt_cv_prog_compiler_pic_works=no ac_outfile=conftest.$ac_objext echo "$lt_simple_compile_test_code" > conftest.$ac_ext lt_compiler_flag="$lt_prog_compiler_pic -DPIC" ## exclude from sc_useless_quotes_in_assignment @@ -10201,8 +10049,7 @@ else case e in #( fi fi $RM conftest* - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_pic_works" >&5 printf "%s\n" "$lt_cv_prog_compiler_pic_works" >&6; } @@ -10238,8 +10085,8 @@ printf %s "checking if $compiler static flag $lt_tmp_static_flag works... " >&6; if test ${lt_cv_prog_compiler_static_works+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_prog_compiler_static_works=no +else $as_nop + lt_cv_prog_compiler_static_works=no save_LDFLAGS=$LDFLAGS LDFLAGS="$LDFLAGS $lt_tmp_static_flag" echo "$lt_simple_link_test_code" > conftest.$ac_ext @@ -10260,8 +10107,7 @@ else case e in #( fi $RM -r conftest* LDFLAGS=$save_LDFLAGS - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_static_works" >&5 printf "%s\n" "$lt_cv_prog_compiler_static_works" >&6; } @@ -10283,8 +10129,8 @@ printf %s "checking if $compiler supports -c -o file.$ac_objext... " >&6; } if test ${lt_cv_prog_compiler_c_o+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_prog_compiler_c_o=no +else $as_nop + lt_cv_prog_compiler_c_o=no $RM -r conftest 2>/dev/null mkdir conftest cd conftest @@ -10324,8 +10170,7 @@ else case e in #( cd .. $RM -r conftest $RM conftest* - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_c_o" >&5 printf "%s\n" "$lt_cv_prog_compiler_c_o" >&6; } @@ -10340,8 +10185,8 @@ printf %s "checking if $compiler supports -c -o file.$ac_objext... " >&6; } if test ${lt_cv_prog_compiler_c_o+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_prog_compiler_c_o=no +else $as_nop + lt_cv_prog_compiler_c_o=no $RM -r conftest 2>/dev/null mkdir conftest cd conftest @@ -10381,8 +10226,7 @@ else case e in #( cd .. $RM -r conftest $RM conftest* - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler_c_o" >&5 printf "%s\n" "$lt_cv_prog_compiler_c_o" >&6; } @@ -10979,8 +10823,8 @@ else if test ${lt_cv_aix_libpath_+y} then : printf %s "(cached) " >&6 -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int @@ -11012,8 +10856,7 @@ rm -f core conftest.err conftest.$ac_objext conftest.beam \ if test -z "$lt_cv_aix_libpath_"; then lt_cv_aix_libpath_=/usr/lib:/lib fi - ;; -esac + fi aix_libpath=$lt_cv_aix_libpath_ @@ -11035,8 +10878,8 @@ else if test ${lt_cv_aix_libpath_+y} then : printf %s "(cached) " >&6 -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int @@ -11068,8 +10911,7 @@ rm -f core conftest.err conftest.$ac_objext conftest.beam \ if test -z "$lt_cv_aix_libpath_"; then lt_cv_aix_libpath_=/usr/lib:/lib fi - ;; -esac + fi aix_libpath=$lt_cv_aix_libpath_ @@ -11320,8 +11162,8 @@ printf %s "checking if $CC understands -b... " >&6; } if test ${lt_cv_prog_compiler__b+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_prog_compiler__b=no +else $as_nop + lt_cv_prog_compiler__b=no save_LDFLAGS=$LDFLAGS LDFLAGS="$LDFLAGS -b" echo "$lt_simple_link_test_code" > conftest.$ac_ext @@ -11342,8 +11184,7 @@ else case e in #( fi $RM -r conftest* LDFLAGS=$save_LDFLAGS - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_prog_compiler__b" >&5 printf "%s\n" "$lt_cv_prog_compiler__b" >&6; } @@ -11391,8 +11232,8 @@ printf %s "checking whether the $host_os linker accepts -exported_symbol... " >& if test ${lt_cv_irix_exported_symbol+y} then : printf %s "(cached) " >&6 -else case e in #( - e) save_LDFLAGS=$LDFLAGS +else $as_nop + save_LDFLAGS=$LDFLAGS LDFLAGS="$LDFLAGS -shared $wl-exported_symbol ${wl}foo $wl-update_registry $wl/dev/null" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -11401,14 +11242,12 @@ _ACEOF if ac_fn_c_try_link "$LINENO" then : lt_cv_irix_exported_symbol=yes -else case e in #( - e) lt_cv_irix_exported_symbol=no ;; -esac +else $as_nop + lt_cv_irix_exported_symbol=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext - LDFLAGS=$save_LDFLAGS ;; -esac + LDFLAGS=$save_LDFLAGS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_irix_exported_symbol" >&5 printf "%s\n" "$lt_cv_irix_exported_symbol" >&6; } @@ -11734,8 +11573,8 @@ printf %s "checking whether -lc should be explicitly linked in... " >&6; } if test ${lt_cv_archive_cmds_need_lc+y} then : printf %s "(cached) " >&6 -else case e in #( - e) $RM conftest* +else $as_nop + $RM conftest* echo "$lt_simple_compile_test_code" > conftest.$ac_ext if { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_compile\""; } >&5 @@ -11771,8 +11610,7 @@ else case e in #( cat conftest.err 1>&5 fi $RM conftest* - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_archive_cmds_need_lc" >&5 printf "%s\n" "$lt_cv_archive_cmds_need_lc" >&6; } @@ -12499,8 +12337,8 @@ linux* | k*bsd*-gnu | kopensolaris*-gnu | gnu*) if test ${lt_cv_shlibpath_overrides_runpath+y} then : printf %s "(cached) " >&6 -else case e in #( - e) lt_cv_shlibpath_overrides_runpath=no +else $as_nop + lt_cv_shlibpath_overrides_runpath=no save_LDFLAGS=$LDFLAGS save_libdir=$libdir eval "libdir=/foo; wl=\"$lt_prog_compiler_wl\"; \ @@ -12527,8 +12365,7 @@ rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext LDFLAGS=$save_LDFLAGS libdir=$save_libdir - ;; -esac + fi shlibpath_overrides_runpath=$lt_cv_shlibpath_overrides_runpath @@ -12965,22 +12802,16 @@ printf %s "checking for dlopen in -ldl... " >&6; } if test ${ac_cv_lib_dl_dlopen+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_check_lib_save_LIBS=$LIBS +else $as_nop + ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. - The 'extern "C"' is for builds by C++ compilers; - although this is not generally supported in C code supporting it here - has little cost and some practical benefit (sr 110532). */ -#ifdef __cplusplus -extern "C" -#endif -char dlopen (void); + builtin and then its argument prototype would still apply. */ +char dlopen (); int main (void) { @@ -12992,27 +12823,24 @@ _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_dl_dlopen=yes -else case e in #( - e) ac_cv_lib_dl_dlopen=no ;; -esac +else $as_nop + ac_cv_lib_dl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS ;; -esac +LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 printf "%s\n" "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = xyes then : lt_cv_dlopen=dlopen lt_cv_dlopen_libs=-ldl -else case e in #( - e) +else $as_nop + lt_cv_dlopen=dyld lt_cv_dlopen_libs= lt_cv_dlopen_self=yes - ;; -esac + fi ;; @@ -13030,28 +12858,22 @@ fi if test "x$ac_cv_func_shl_load" = xyes then : lt_cv_dlopen=shl_load -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for shl_load in -ldld" >&5 printf %s "checking for shl_load in -ldld... " >&6; } if test ${ac_cv_lib_dld_shl_load+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_check_lib_save_LIBS=$LIBS +else $as_nop + ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. - The 'extern "C"' is for builds by C++ compilers; - although this is not generally supported in C code supporting it here - has little cost and some practical benefit (sr 110532). */ -#ifdef __cplusplus -extern "C" -#endif -char shl_load (void); + builtin and then its argument prototype would still apply. */ +char shl_load (); int main (void) { @@ -13063,47 +12885,39 @@ _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_dld_shl_load=yes -else case e in #( - e) ac_cv_lib_dld_shl_load=no ;; -esac +else $as_nop + ac_cv_lib_dld_shl_load=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS ;; -esac +LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_shl_load" >&5 printf "%s\n" "$ac_cv_lib_dld_shl_load" >&6; } if test "x$ac_cv_lib_dld_shl_load" = xyes then : lt_cv_dlopen=shl_load lt_cv_dlopen_libs=-ldld -else case e in #( - e) ac_fn_c_check_func "$LINENO" "dlopen" "ac_cv_func_dlopen" +else $as_nop + ac_fn_c_check_func "$LINENO" "dlopen" "ac_cv_func_dlopen" if test "x$ac_cv_func_dlopen" = xyes then : lt_cv_dlopen=dlopen -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 printf %s "checking for dlopen in -ldl... " >&6; } if test ${ac_cv_lib_dl_dlopen+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_check_lib_save_LIBS=$LIBS +else $as_nop + ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. - The 'extern "C"' is for builds by C++ compilers; - although this is not generally supported in C code supporting it here - has little cost and some practical benefit (sr 110532). */ -#ifdef __cplusplus -extern "C" -#endif -char dlopen (void); + builtin and then its argument prototype would still apply. */ +char dlopen (); int main (void) { @@ -13115,42 +12929,34 @@ _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_dl_dlopen=yes -else case e in #( - e) ac_cv_lib_dl_dlopen=no ;; -esac +else $as_nop + ac_cv_lib_dl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS ;; -esac +LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 printf "%s\n" "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = xyes then : lt_cv_dlopen=dlopen lt_cv_dlopen_libs=-ldl -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -lsvld" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -lsvld" >&5 printf %s "checking for dlopen in -lsvld... " >&6; } if test ${ac_cv_lib_svld_dlopen+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_check_lib_save_LIBS=$LIBS +else $as_nop + ac_check_lib_save_LIBS=$LIBS LIBS="-lsvld $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. - The 'extern "C"' is for builds by C++ compilers; - although this is not generally supported in C code supporting it here - has little cost and some practical benefit (sr 110532). */ -#ifdef __cplusplus -extern "C" -#endif -char dlopen (void); + builtin and then its argument prototype would still apply. */ +char dlopen (); int main (void) { @@ -13162,42 +12968,34 @@ _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_svld_dlopen=yes -else case e in #( - e) ac_cv_lib_svld_dlopen=no ;; -esac +else $as_nop + ac_cv_lib_svld_dlopen=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS ;; -esac +LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_svld_dlopen" >&5 printf "%s\n" "$ac_cv_lib_svld_dlopen" >&6; } if test "x$ac_cv_lib_svld_dlopen" = xyes then : lt_cv_dlopen=dlopen lt_cv_dlopen_libs=-lsvld -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dld_link in -ldld" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dld_link in -ldld" >&5 printf %s "checking for dld_link in -ldld... " >&6; } if test ${ac_cv_lib_dld_dld_link+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_check_lib_save_LIBS=$LIBS +else $as_nop + ac_check_lib_save_LIBS=$LIBS LIBS="-ldld $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. - The 'extern "C"' is for builds by C++ compilers; - although this is not generally supported in C code supporting it here - has little cost and some practical benefit (sr 110532). */ -#ifdef __cplusplus -extern "C" -#endif -char dld_link (void); + builtin and then its argument prototype would still apply. */ +char dld_link (); int main (void) { @@ -13209,14 +13007,12 @@ _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_dld_dld_link=yes -else case e in #( - e) ac_cv_lib_dld_dld_link=no ;; -esac +else $as_nop + ac_cv_lib_dld_dld_link=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS ;; -esac +LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dld_dld_link" >&5 printf "%s\n" "$ac_cv_lib_dld_dld_link" >&6; } @@ -13225,24 +13021,19 @@ then : lt_cv_dlopen=dld_link lt_cv_dlopen_libs=-ldld fi - ;; -esac + fi - ;; -esac + fi - ;; -esac + fi - ;; -esac + fi - ;; -esac + fi ;; @@ -13270,8 +13061,8 @@ printf %s "checking whether a program can dlopen itself... " >&6; } if test ${lt_cv_dlopen_self+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test yes = "$cross_compiling"; then : +else $as_nop + if test yes = "$cross_compiling"; then : lt_cv_dlopen_self=cross else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 @@ -13365,8 +13156,7 @@ _LT_EOF fi rm -fr conftest* - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_dlopen_self" >&5 printf "%s\n" "$lt_cv_dlopen_self" >&6; } @@ -13378,8 +13168,8 @@ printf %s "checking whether a statically linked program can dlopen itself... " > if test ${lt_cv_dlopen_self_static+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test yes = "$cross_compiling"; then : +else $as_nop + if test yes = "$cross_compiling"; then : lt_cv_dlopen_self_static=cross else lt_dlunknown=0; lt_dlno_uscore=1; lt_dlneed_uscore=2 @@ -13473,8 +13263,7 @@ _LT_EOF fi rm -fr conftest* - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lt_cv_dlopen_self_static" >&5 printf "%s\n" "$lt_cv_dlopen_self_static" >&6; } @@ -13646,8 +13435,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_DEP_CC+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$DEP_CC"; then +else $as_nop + if test -n "$DEP_CC"; then ac_cv_prog_DEP_CC="$DEP_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -13669,8 +13458,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi DEP_CC=$ac_cv_prog_DEP_CC if test -n "$DEP_CC"; then @@ -13696,8 +13484,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_DEP_CC+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_DEP_CC"; then +else $as_nop + if test -n "$ac_ct_DEP_CC"; then ac_cv_prog_ac_ct_DEP_CC="$ac_ct_DEP_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -13719,8 +13507,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_DEP_CC=$ac_cv_prog_ac_ct_DEP_CC if test -n "$ac_ct_DEP_CC"; then @@ -13757,9 +13544,8 @@ case $enable_dependency_generation in #( if test "$DEP_CC" = "false" then : as_fn_error $? "The MSVC ports cannot generate dependency information. Install gcc (or another CC-like compiler)" "$LINENO" 5 -else case e in #( - e) compute_deps=true ;; -esac +else $as_nop + compute_deps=true fi ;; #( no) : compute_deps=false ;; #( @@ -13769,13 +13555,11 @@ then : if test "$DEP_CC" = "false" then : compute_deps=false -else case e in #( - e) compute_deps=true ;; -esac +else $as_nop + compute_deps=true fi -else case e in #( - e) compute_deps=false ;; -esac +else $as_nop + compute_deps=false fi ;; esac @@ -13794,9 +13578,8 @@ case $host in #( if test "$host_cpu" = "x86_64" then : machine="-machine:AMD64 " -else case e in #( - e) machine="" ;; -esac +else $as_nop + machine="" fi mklib="link -lib -nologo $machine /out:\$(1) \$(2)" ;; #( @@ -13822,8 +13605,8 @@ if test -z "$CPP"; then if test ${ac_cv_prog_CPP+y} then : printf %s "(cached) " >&6 -else case e in #( - e) # Double quotes because $CC needs to be expanded +else $as_nop + # Double quotes because $CC needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" cpp /lib/cpp do ac_preproc_ok=false @@ -13841,10 +13624,9 @@ _ACEOF if ac_fn_c_try_cpp "$LINENO" then : -else case e in #( - e) # Broken: fails on valid input. -continue ;; -esac +else $as_nop + # Broken: fails on valid input. +continue fi rm -f conftest.err conftest.i conftest.$ac_ext @@ -13858,16 +13640,15 @@ if ac_fn_c_try_cpp "$LINENO" then : # Broken: success on invalid input. continue -else case e in #( - e) # Passes both tests. +else $as_nop + # Passes both tests. ac_preproc_ok=: -break ;; -esac +break fi rm -f conftest.err conftest.i conftest.$ac_ext done -# Because of 'break', _AC_PREPROC_IFELSE's cleaning code was skipped. +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok then : @@ -13876,8 +13657,7 @@ fi done ac_cv_prog_CPP=$CPP - ;; -esac + fi CPP=$ac_cv_prog_CPP else @@ -13900,10 +13680,9 @@ _ACEOF if ac_fn_c_try_cpp "$LINENO" then : -else case e in #( - e) # Broken: fails on valid input. -continue ;; -esac +else $as_nop + # Broken: fails on valid input. +continue fi rm -f conftest.err conftest.i conftest.$ac_ext @@ -13917,26 +13696,24 @@ if ac_fn_c_try_cpp "$LINENO" then : # Broken: success on invalid input. continue -else case e in #( - e) # Passes both tests. +else $as_nop + # Passes both tests. ac_preproc_ok=: -break ;; -esac +break fi rm -f conftest.err conftest.i conftest.$ac_ext done -# Because of 'break', _AC_PREPROC_IFELSE's cleaning code was skipped. +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok then : -else case e in #( - e) { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} +else $as_nop + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "C preprocessor \"$CPP\" fails sanity check -See 'config.log' for more details" "$LINENO" 5; } ;; -esac +See \`config.log' for more details" "$LINENO" 5; } fi ac_ext=c @@ -13987,21 +13764,19 @@ then : if test ${ocaml_cv_cc_vendor2+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ocaml_cv_cc_vendor2=`sed -e '/^#/d' conftest.i | tr -s '[:space:]' '-' \ - | sed -e 's/^-//' -e 's/-$//'` ;; -esac +else $as_nop + ocaml_cv_cc_vendor2=`sed -e '/^#/d' conftest.i | tr -s '[:space:]' '-' \ + | sed -e 's/^-//' -e 's/-$//'` fi # Domain of values was changed in #12768, so the cache key became different # from the variable ocaml_cc_vendor="$ocaml_cv_cc_vendor2" -else case e in #( - e) { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} +else $as_nop + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "unexpected preprocessor failure -See 'config.log' for more details" "$LINENO" 5; } ;; -esac +See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest.err conftest.i conftest.$ac_ext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ocaml_cc_vendor" >&5 @@ -14020,8 +13795,8 @@ then : # autoconf displays a warning if this parameter is missing, but # cross-compilation mode was disabled above. assert=false -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) {return 0;} _ACEOF @@ -14030,15 +13805,13 @@ then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } host_runnable=true -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } - host_runnable=false ;; -esac + host_runnable=false fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext ;; -esac + conftest.$ac_objext conftest.beam conftest.$ac_ext fi cross_compiling="$old_cross_compiling" @@ -14138,9 +13911,8 @@ then : ocamltest_unix_impl="real" unix_directory="otherlibs/unix" unix_library="${unix_directory}/unix" -else case e in #( - e) ocamltest_libunix="None" ;; -esac +else $as_nop + ocamltest_libunix="None" fi if test x"$enable_str_lib" != "xno" @@ -14160,8 +13932,8 @@ printf %s "checking whether #! works in shell scripts... " >&6; } if test ${ac_cv_sys_interpreter+y} then : printf %s "(cached) " >&6 -else case e in #( - e) echo '#! /bin/cat +else $as_nop + echo '#! /bin/cat exit 69 ' >conftest chmod u+x conftest @@ -14171,8 +13943,7 @@ if test $? -ne 69; then else ac_cv_sys_interpreter=no fi -rm -f conftest ;; -esac +rm -f conftest fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sys_interpreter" >&5 printf "%s\n" "$ac_cv_sys_interpreter" >&6; } @@ -14216,9 +13987,8 @@ ac_config_commands="$ac_config_commands shebang" if test x"$host" = x"$target" then : cross_compiler=false -else case e in #( - e) cross_compiler=true ;; -esac +else $as_nop + cross_compiler=true fi # Checks for programs @@ -14251,14 +14021,14 @@ case $ocaml_cc_vendor in #( esac # Use -Wold-style-declaration if supported -as_CACHEVAR=`printf "%s\n" "ax_cv_check_cflags_$warn_error_flag_-Wold-style-declaration" | sed "$as_sed_sh"` +as_CACHEVAR=`printf "%s\n" "ax_cv_check_cflags_$warn_error_flag_-Wold-style-declaration" | $as_tr_sh` { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether C compiler accepts -Wold-style-declaration" >&5 printf %s "checking whether C compiler accepts -Wold-style-declaration... " >&6; } if eval test \${$as_CACHEVAR+y} then : printf %s "(cached) " >&6 -else case e in #( - e) +else $as_nop + ax_check_save_flags=$CFLAGS CFLAGS="$CFLAGS $warn_error_flag -Wold-style-declaration" cat confdefs.h - <<_ACEOF >conftest.$ac_ext @@ -14275,13 +14045,11 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : eval "$as_CACHEVAR=yes" -else case e in #( - e) eval "$as_CACHEVAR=no" ;; -esac +else $as_nop + eval "$as_CACHEVAR=no" fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - CFLAGS=$ax_check_save_flags ;; -esac + CFLAGS=$ax_check_save_flags fi eval ac_res=\$$as_CACHEVAR { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 @@ -14289,9 +14057,8 @@ printf "%s\n" "$ac_res" >&6; } if eval test \"x\$"$as_CACHEVAR"\" = x"yes" then : cc_warnings="$cc_warnings -Wold-style-declaration" -else case e in #( - e) : ;; -esac +else $as_nop + : fi @@ -14350,11 +14117,10 @@ then : cl_has_volatile_metadata=true { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } -else case e in #( - e) cl_has_volatile_metadata=false +else $as_nop + cl_has_volatile_metadata=false { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } ;; -esac +printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext CFLAGS="$saved_CFLAGS" @@ -14412,9 +14178,8 @@ then : *) : ;; esac -else case e in #( - e) supports_shared_libraries=true ;; -esac +else $as_nop + supports_shared_libraries=true fi # Define flexlink chain and flags correctly for the different Windows ports @@ -14454,8 +14219,8 @@ then : flexdll_source_dir='' { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: disabled" >&5 printf "%s\n" "disabled" >&6; } -else case e in #( - e) flexmsg='' +else $as_nop + flexmsg='' case $target in #( *-*-cygwin*|*-w64-mingw32*|*-pc-windows) : if test x"$with_flexdll" = 'x' || test x"$with_flexdll" = 'xflexdll' @@ -14465,17 +14230,16 @@ then : flexdll_source_dir=flexdll iflexdir='$(ROOTDIR)/flexdll' with_flexdll="$iflexdir" -else case e in #( - e) if test x"$with_flexdll" != 'x' +else $as_nop + if test x"$with_flexdll" != 'x' then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: requested but not available" >&5 printf "%s\n" "requested but not available" >&6; } as_fn_error $? "exiting" "$LINENO" 5 -fi ;; -esac fi -else case e in #( - e) rm -rf flexdll-sources +fi +else $as_nop + rm -rf flexdll-sources if test -f "$with_flexdll/flexdll.h" then : mkdir -p flexdll-sources @@ -14483,26 +14247,23 @@ then : flexdll_source_dir='flexdll-sources' iflexdir='$(ROOTDIR)/flexdll-sources' flexmsg=" (from $with_flexdll)" -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: requested but not available" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: requested but not available" >&5 printf "%s\n" "requested but not available" >&6; } - as_fn_error $? "exiting" "$LINENO" 5 ;; -esac -fi ;; -esac + as_fn_error $? "exiting" "$LINENO" 5 +fi fi if test x"$flexdll_source_dir" = 'x' then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $iflexdir$flexmsg" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $iflexdir$flexmsg" >&5 printf "%s\n" "$iflexdir$flexmsg" >&6; } bootstrapping_flexdll=true flexdll_dir=\"+flexdll\" # The submodule should be searched *before* any other -I paths - internal_cppflags="-I $iflexdir $internal_cppflags" ;; -esac + internal_cppflags="-I $iflexdir $internal_cppflags" fi ;; #( *) : if test x"$with_flexdll" != 'x' @@ -14511,7 +14272,6 @@ then : printf "%s\n" "requested but not supported" >&6; } as_fn_error $? "exiting" "$LINENO" 5 fi ;; -esac ;; esac fi @@ -14522,8 +14282,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_flexlink+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$flexlink"; then +else $as_nop + if test -n "$flexlink"; then ac_cv_prog_flexlink="$flexlink" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -14545,8 +14305,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi flexlink=$ac_cv_prog_flexlink if test -n "$flexlink"; then @@ -14608,19 +14367,17 @@ if ac_fn_c_try_link "$LINENO" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } - as_fn_error $? "$flexlink does not work" "$LINENO" 5 ;; -esac + as_fn_error $? "$flexlink does not work" "$LINENO" 5 fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unexpected compile error" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unexpected compile error" >&5 printf "%s\n" "unexpected compile error" >&6; } - as_fn_error $? "error calling the C compiler" "$LINENO" 5 ;; -esac + as_fn_error $? "error calling the C compiler" "$LINENO" 5 fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext @@ -14672,9 +14429,8 @@ fi if test "x$ac_cv_header_flexdll_h" = xyes then : have_flexdll_h=yes -else case e in #( - e) have_flexdll_h=no ;; -esac +else $as_nop + have_flexdll_h=no fi if test x"$have_flexdll_h" = 'xno' @@ -14730,10 +14486,9 @@ then : have_flexdll_h=yes { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } ;; -esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } fi @@ -14796,11 +14551,10 @@ then : mkexe_cmd="flexlink -exe -chain ${flexdll_chain} ${flexlink_flags}" mkexe_cflags='' mkexe_ldflags_prefix='-link ' -else case e in #( - e) mkexe_extra_flags='' +else $as_nop + mkexe_extra_flags='' oc_ldflags='-Wl,--stack,16777216' - ;; -esac + fi ostype="Cygwin" ;; #( *,*-*-mingw32*) : @@ -14865,8 +14619,8 @@ if test -z "$INSTALL"; then if test ${ac_cv_path_install+y} then : printf %s "(cached) " >&6 -else case e in #( - e) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +else $as_nop + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS @@ -14920,8 +14674,7 @@ esac IFS=$as_save_IFS rm -rf conftest.one conftest.two conftest.dir - ;; -esac + fi if test ${ac_cv_path_install+y}; then INSTALL=$ac_cv_path_install @@ -14953,21 +14706,15 @@ printf %s "checking for library containing cos... " >&6; } if test ${ac_cv_search_cos+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_func_search_save_LIBS=$LIBS +else $as_nop + ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. - The 'extern "C"' is for builds by C++ compilers; - although this is not generally supported in C code supporting it here - has little cost and some practical benefit (sr 110532). */ -#ifdef __cplusplus -extern "C" -#endif -char cos (void); + builtin and then its argument prototype would still apply. */ +char cos (); int main (void) { @@ -14998,13 +14745,11 @@ done if test ${ac_cv_search_cos+y} then : -else case e in #( - e) ac_cv_search_cos=no ;; -esac +else $as_nop + ac_cv_search_cos=no fi rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS ;; -esac +LIBS=$ac_func_search_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_cos" >&5 printf "%s\n" "$ac_cv_search_cos" >&6; } @@ -15117,11 +14862,10 @@ ac_fn_c_check_type "$LINENO" "off_t" "ac_cv_type_off_t" "$ac_includes_default" if test "x$ac_cv_type_off_t" = xyes then : -else case e in #( - e) +else $as_nop + printf "%s\n" "#define off_t long int" >>confdefs.h - ;; -esac + fi @@ -15131,30 +14875,28 @@ fi # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects -# declarations like 'int a3[[(sizeof (unsigned char)) >= 0]];'. +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of int" >&5 printf %s "checking size of int... " >&6; } if test ${ac_cv_sizeof_int+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (int))" "ac_cv_sizeof_int" "$ac_includes_default" +else $as_nop + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (int))" "ac_cv_sizeof_int" "$ac_includes_default" then : -else case e in #( - e) if test "$ac_cv_type_int" = yes; then - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} +else $as_nop + if test "$ac_cv_type_int" = yes; then + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (int) -See 'config.log' for more details" "$LINENO" 5; } +See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_int=0 - fi ;; -esac + fi fi - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_int" >&5 printf "%s\n" "$ac_cv_sizeof_int" >&6; } @@ -15166,30 +14908,28 @@ printf "%s\n" "#define SIZEOF_INT $ac_cv_sizeof_int" >>confdefs.h # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects -# declarations like 'int a3[[(sizeof (unsigned char)) >= 0]];'. +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of long" >&5 printf %s "checking size of long... " >&6; } if test ${ac_cv_sizeof_long+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long))" "ac_cv_sizeof_long" "$ac_includes_default" +else $as_nop + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long))" "ac_cv_sizeof_long" "$ac_includes_default" then : -else case e in #( - e) if test "$ac_cv_type_long" = yes; then - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} +else $as_nop + if test "$ac_cv_type_long" = yes; then + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (long) -See 'config.log' for more details" "$LINENO" 5; } +See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_long=0 - fi ;; -esac + fi fi - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_long" >&5 printf "%s\n" "$ac_cv_sizeof_long" >&6; } @@ -15201,30 +14941,28 @@ printf "%s\n" "#define SIZEOF_LONG $ac_cv_sizeof_long" >>confdefs.h # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects -# declarations like 'int a3[[(sizeof (unsigned char)) >= 0]];'. +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of long *" >&5 printf %s "checking size of long *... " >&6; } if test ${ac_cv_sizeof_long_p+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long *))" "ac_cv_sizeof_long_p" "$ac_includes_default" +else $as_nop + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long *))" "ac_cv_sizeof_long_p" "$ac_includes_default" then : -else case e in #( - e) if test "$ac_cv_type_long_p" = yes; then - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} +else $as_nop + if test "$ac_cv_type_long_p" = yes; then + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (long *) -See 'config.log' for more details" "$LINENO" 5; } +See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_long_p=0 - fi ;; -esac + fi fi - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_long_p" >&5 printf "%s\n" "$ac_cv_sizeof_long_p" >&6; } @@ -15236,30 +14974,28 @@ printf "%s\n" "#define SIZEOF_LONG_P $ac_cv_sizeof_long_p" >>confdefs.h # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects -# declarations like 'int a3[[(sizeof (unsigned char)) >= 0]];'. +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of short" >&5 printf %s "checking size of short... " >&6; } if test ${ac_cv_sizeof_short+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (short))" "ac_cv_sizeof_short" "$ac_includes_default" +else $as_nop + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (short))" "ac_cv_sizeof_short" "$ac_includes_default" then : -else case e in #( - e) if test "$ac_cv_type_short" = yes; then - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} +else $as_nop + if test "$ac_cv_type_short" = yes; then + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (short) -See 'config.log' for more details" "$LINENO" 5; } +See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_short=0 - fi ;; -esac + fi fi - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_short" >&5 printf "%s\n" "$ac_cv_sizeof_short" >&6; } @@ -15271,30 +15007,28 @@ printf "%s\n" "#define SIZEOF_SHORT $ac_cv_sizeof_short" >>confdefs.h # The cast to long int works around a bug in the HP C Compiler # version HP92453-01 B.11.11.23709.GP, which incorrectly rejects -# declarations like 'int a3[[(sizeof (unsigned char)) >= 0]];'. +# declarations like `int a3[[(sizeof (unsigned char)) >= 0]];'. # This bug is HP SR number 8606223364. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking size of long long" >&5 printf %s "checking size of long long... " >&6; } if test ${ac_cv_sizeof_long_long+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long long))" "ac_cv_sizeof_long_long" "$ac_includes_default" +else $as_nop + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long long))" "ac_cv_sizeof_long_long" "$ac_includes_default" then : -else case e in #( - e) if test "$ac_cv_type_long_long" = yes; then - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} +else $as_nop + if test "$ac_cv_type_long_long" = yes; then + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute sizeof (long long) -See 'config.log' for more details" "$LINENO" 5; } +See \`config.log' for more details" "$LINENO" 5; } else ac_cv_sizeof_long_long=0 - fi ;; -esac + fi fi - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_sizeof_long_long" >&5 printf "%s\n" "$ac_cv_sizeof_long_long" >&6; } @@ -15313,10 +15047,9 @@ then : bits=64; arch64=true printf "%s\n" "#define ARCH_SIXTYFOUR 1" >>confdefs.h -else case e in #( - e) as_fn_error $? "Neither 32 nor 64 bits architecture." "$LINENO" 5 - ;; -esac +else $as_nop + as_fn_error $? "Neither 32 nor 64 bits architecture." "$LINENO" 5 + fi if test "x$ac_cv_sizeof_int" != "x4" && test "x$ac_cv_sizeof_long" != "x4" \ @@ -15346,8 +15079,8 @@ printf %s "checking whether byte ordering is bigendian... " >&6; } if test ${ac_cv_c_bigendian+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_cv_c_bigendian=unknown +else $as_nop + ac_cv_c_bigendian=unknown # See if we're dealing with a universal compiler. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -15393,8 +15126,8 @@ rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext int main (void) { -#if ! (defined BYTE_ORDER && defined BIG_ENDIAN \\ - && defined LITTLE_ENDIAN && BYTE_ORDER && BIG_ENDIAN \\ +#if ! (defined BYTE_ORDER && defined BIG_ENDIAN \ + && defined LITTLE_ENDIAN && BYTE_ORDER && BIG_ENDIAN \ && LITTLE_ENDIAN) bogus endian macros #endif @@ -15425,9 +15158,8 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_c_bigendian=yes -else case e in #( - e) ac_cv_c_bigendian=no ;; -esac +else $as_nop + ac_cv_c_bigendian=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi @@ -15471,9 +15203,8 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_c_bigendian=yes -else case e in #( - e) ac_cv_c_bigendian=no ;; -esac +else $as_nop + ac_cv_c_bigendian=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi @@ -15500,23 +15231,22 @@ unsigned short int ascii_mm[] = int use_ebcdic (int i) { return ebcdic_mm[i] + ebcdic_ii[i]; } - int - main (int argc, char **argv) - { - /* Intimidate the compiler so that it does not - optimize the arrays away. */ - char *p = argv[0]; - ascii_mm[1] = *p++; ebcdic_mm[1] = *p++; - ascii_ii[1] = *p++; ebcdic_ii[1] = *p++; - return use_ascii (argc) == use_ebcdic (*p); - } + extern int foo; + +int +main (void) +{ +return use_ascii (foo) == use_ebcdic (foo); + ; + return 0; +} _ACEOF -if ac_fn_c_try_link "$LINENO" +if ac_fn_c_try_compile "$LINENO" then : - if grep BIGenDianSyS conftest$ac_exeext >/dev/null; then + if grep BIGenDianSyS conftest.$ac_objext >/dev/null; then ac_cv_c_bigendian=yes fi - if grep LiTTleEnDian conftest$ac_exeext >/dev/null ; then + if grep LiTTleEnDian conftest.$ac_objext >/dev/null ; then if test "$ac_cv_c_bigendian" = unknown; then ac_cv_c_bigendian=no else @@ -15525,10 +15255,9 @@ then : fi fi fi -rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext conftest.$ac_ext -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_includes_default int @@ -15551,17 +15280,14 @@ _ACEOF if ac_fn_c_try_run "$LINENO" then : ac_cv_c_bigendian=no -else case e in #( - e) ac_cv_c_bigendian=yes ;; -esac +else $as_nop + ac_cv_c_bigendian=yes fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext ;; -esac + conftest.$ac_objext conftest.beam conftest.$ac_ext fi - fi ;; -esac + fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_bigendian" >&5 printf "%s\n" "$ac_cv_c_bigendian" >&6; } @@ -15590,24 +15316,22 @@ printf %s "checking alignment of double... " >&6; } if test ${ac_cv_alignof_double+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if ac_fn_c_compute_int "$LINENO" "(long int) offsetof (ac__type_alignof_, y)" "ac_cv_alignof_double" "$ac_includes_default +else $as_nop + if ac_fn_c_compute_int "$LINENO" "(long int) offsetof (ac__type_alignof_, y)" "ac_cv_alignof_double" "$ac_includes_default typedef struct { char x; double y; } ac__type_alignof_;" then : -else case e in #( - e) if test "$ac_cv_type_double" = yes; then - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} +else $as_nop + if test "$ac_cv_type_double" = yes; then + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute alignment of double -See 'config.log' for more details" "$LINENO" 5; } +See \`config.log' for more details" "$LINENO" 5; } else ac_cv_alignof_double=0 - fi ;; -esac + fi fi - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_alignof_double" >&5 printf "%s\n" "$ac_cv_alignof_double" >&6; } @@ -15624,24 +15348,22 @@ printf %s "checking alignment of long... " >&6; } if test ${ac_cv_alignof_long+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if ac_fn_c_compute_int "$LINENO" "(long int) offsetof (ac__type_alignof_, y)" "ac_cv_alignof_long" "$ac_includes_default +else $as_nop + if ac_fn_c_compute_int "$LINENO" "(long int) offsetof (ac__type_alignof_, y)" "ac_cv_alignof_long" "$ac_includes_default typedef struct { char x; long y; } ac__type_alignof_;" then : -else case e in #( - e) if test "$ac_cv_type_long" = yes; then - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} +else $as_nop + if test "$ac_cv_type_long" = yes; then + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute alignment of long -See 'config.log' for more details" "$LINENO" 5; } +See \`config.log' for more details" "$LINENO" 5; } else ac_cv_alignof_long=0 - fi ;; -esac + fi fi - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_alignof_long" >&5 printf "%s\n" "$ac_cv_alignof_long" >&6; } @@ -15658,24 +15380,22 @@ printf %s "checking alignment of long long... " >&6; } if test ${ac_cv_alignof_long_long+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if ac_fn_c_compute_int "$LINENO" "(long int) offsetof (ac__type_alignof_, y)" "ac_cv_alignof_long_long" "$ac_includes_default +else $as_nop + if ac_fn_c_compute_int "$LINENO" "(long int) offsetof (ac__type_alignof_, y)" "ac_cv_alignof_long_long" "$ac_includes_default typedef struct { char x; long long y; } ac__type_alignof_;" then : -else case e in #( - e) if test "$ac_cv_type_long_long" = yes; then - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} +else $as_nop + if test "$ac_cv_type_long_long" = yes; then + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot compute alignment of long long -See 'config.log' for more details" "$LINENO" 5; } +See \`config.log' for more details" "$LINENO" 5; } else ac_cv_alignof_long_long=0 - fi ;; -esac + fi fi - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_alignof_long_long" >&5 printf "%s\n" "$ac_cv_alignof_long_long" >&6; } @@ -15702,14 +15422,13 @@ fi then : printf "%s\n" "#define ARCH_ALIGN_INT64 1" >>confdefs.h -else case e in #( - e) if test "x$ac_cv_sizeof_long_long" = "x8" && +else $as_nop + if test "x$ac_cv_sizeof_long_long" = "x8" && test "$ac_cv_alignof_long_long" -gt 4 then : printf "%s\n" "#define ARCH_ALIGN_INT64 1" >>confdefs.h -fi ;; -esac +fi fi ;; esac @@ -15755,11 +15474,10 @@ then : cc_supports_atomic=true { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } -else case e in #( - e) cc_supports_atomic=false +else $as_nop + cc_supports_atomic=false { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } ;; -esac +printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext @@ -15767,10 +15485,10 @@ rm -f core conftest.err conftest.$ac_objext conftest.beam \ if ! $cc_supports_atomic then : - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "C11 atomic support is required, use another C compiler -See 'config.log' for more details" "$LINENO" 5; } +See \`config.log' for more details" "$LINENO" 5; } fi # Full support for thread local storage @@ -15987,11 +15705,10 @@ then : cc_has_fno_tree_vrp=true { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } -else case e in #( - e) cc_has_fno_tree_vrp=false +else $as_nop + cc_has_fno_tree_vrp=false { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } ;; -esac +printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext CFLAGS="$saved_CFLAGS" @@ -16017,10 +15734,9 @@ then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } ;; -esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext @@ -16043,10 +15759,9 @@ then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } ;; -esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext CFLAGS="$saved_CFLAGS" @@ -16150,9 +15865,8 @@ case $host in #( if $arch64 then : has_native_backend=yes; arch=arm64; system=linux -else case e in #( - e) arch=arm; model=armv8; system=linux ;; -esac +else $as_nop + arch=arm; model=armv8; system=linux fi ;; #( aarch64-*-freebsd*) : has_native_backend=yes; arch=arm64; system=freebsd ;; #( @@ -16181,14 +15895,13 @@ if test x"$enable_stack_checks" = xyes then : printf "%s\n" "#define STACK_CHECKS_ENABLED 1" >>confdefs.h -else case e in #( - e) if test x"$arch" != xamd64 +else $as_nop + if test x"$arch" != xamd64 then : enable_stack_checks=yes printf "%s\n" "#define STACK_CHECKS_ENABLED 1" >>confdefs.h -fi ;; -esac +fi fi native_cflags='' @@ -16219,9 +15932,8 @@ esac if $native_compiler then : default_build_target=world.opt -else case e in #( - e) default_build_target=world ;; -esac +else $as_nop + default_build_target=world fi if ! $native_compiler @@ -16232,16 +15944,14 @@ fi if $natdynlink then : cmxs="cmxs" -else case e in #( - e) cmxs="cmx" ;; -esac +else $as_nop + cmxs="cmx" fi if $natdynlink then : natdynlink_archive="dynlink.cmxa" -else case e in #( - e) natdynlink_archive="" ;; -esac +else $as_nop + natdynlink_archive="" fi printf "%s\n" "#define OCAML_OS_TYPE \"$ostype\"" >>confdefs.h @@ -16255,8 +15965,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_DIRECT_LD+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$DIRECT_LD"; then +else $as_nop + if test -n "$DIRECT_LD"; then ac_cv_prog_DIRECT_LD="$DIRECT_LD" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -16278,8 +15988,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi DIRECT_LD=$ac_cv_prog_DIRECT_LD if test -n "$DIRECT_LD"; then @@ -16301,8 +16010,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_DIRECT_LD+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ac_ct_DIRECT_LD"; then +else $as_nop + if test -n "$ac_ct_DIRECT_LD"; then ac_cv_prog_ac_ct_DIRECT_LD="$ac_ct_DIRECT_LD" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -16324,8 +16033,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi ac_ct_DIRECT_LD=$ac_cv_prog_ac_ct_DIRECT_LD if test -n "$ac_ct_DIRECT_LD"; then @@ -16362,9 +16070,8 @@ then : if $arch64 then : PACKLD_FLAGS=' -m elf64ppc' -else case e in #( - e) PACKLD_FLAGS=' -m elf32ppclinux' ;; -esac +else $as_nop + PACKLD_FLAGS=' -m elf32ppclinux' fi ;; #( *) : PACKLD_FLAGS='' ;; @@ -16381,9 +16088,8 @@ esac *) : PACKLD="$DIRECT_LD -r$PACKLD_FLAGS -o " ;; esac -else case e in #( - e) PACKLD="$PARTIALLD -o " ;; -esac +else $as_nop + PACKLD="$PARTIALLD -o " fi # Disable PIE at link time when ocamlopt does not produce position-independent @@ -16424,8 +16130,8 @@ printf %s "checking whether C compiler accepts -Wa,-mbranches-within-32B-boundar if test ${ax_cv_check_cflags___Wa__mbranches_within_32B_boundaries+y} then : printf %s "(cached) " >&6 -else case e in #( - e) +else $as_nop + ax_check_save_flags=$CFLAGS CFLAGS="$CFLAGS -Wa,-mbranches-within-32B-boundaries" cat confdefs.h - <<_ACEOF >conftest.$ac_ext @@ -16442,22 +16148,19 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : ax_cv_check_cflags___Wa__mbranches_within_32B_boundaries=yes -else case e in #( - e) ax_cv_check_cflags___Wa__mbranches_within_32B_boundaries=no ;; -esac +else $as_nop + ax_cv_check_cflags___Wa__mbranches_within_32B_boundaries=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - CFLAGS=$ax_check_save_flags ;; -esac + CFLAGS=$ax_check_save_flags fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ax_cv_check_cflags___Wa__mbranches_within_32B_boundaries" >&5 printf "%s\n" "$ax_cv_check_cflags___Wa__mbranches_within_32B_boundaries" >&6; } if test "x$ax_cv_check_cflags___Wa__mbranches_within_32B_boundaries" = xyes then : intel_jcc_bug_cflags=-Wa,-mbranches-within-32B-boundaries -else case e in #( - e) : ;; -esac +else $as_nop + : fi ;; #( *) : @@ -16476,8 +16179,8 @@ printf %s "checking whether C compiler accepts -Wa,-mbranches-within-32B-boundar if test ${ax_cv_check_cflags___Wa__mbranches_within_32B_boundaries+y} then : printf %s "(cached) " >&6 -else case e in #( - e) +else $as_nop + ax_check_save_flags=$CFLAGS CFLAGS="$CFLAGS -Wa,-mbranches-within-32B-boundaries" cat confdefs.h - <<_ACEOF >conftest.$ac_ext @@ -16494,22 +16197,19 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : ax_cv_check_cflags___Wa__mbranches_within_32B_boundaries=yes -else case e in #( - e) ax_cv_check_cflags___Wa__mbranches_within_32B_boundaries=no ;; -esac +else $as_nop + ax_cv_check_cflags___Wa__mbranches_within_32B_boundaries=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - CFLAGS=$ax_check_save_flags ;; -esac + CFLAGS=$ax_check_save_flags fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ax_cv_check_cflags___Wa__mbranches_within_32B_boundaries" >&5 printf "%s\n" "$ax_cv_check_cflags___Wa__mbranches_within_32B_boundaries" >&6; } if test "x$ax_cv_check_cflags___Wa__mbranches_within_32B_boundaries" = xyes then : intel_jcc_bug_cflags=-Wa,-mbranches-within-32B-boundaries -else case e in #( - e) : ;; -esac +else $as_nop + : fi ;; #( *) : @@ -16523,19 +16223,17 @@ then : toolpref="${target_alias}-" as_target="$target" as_cpu="$target_cpu" -else case e in #( - e) if test -n "$host_alias" +else $as_nop + if test -n "$host_alias" then : toolpref="${host_alias}-" as_target="$host" as_cpu="$host_cpu" -else case e in #( - e) toolpref="" +else $as_nop + toolpref="" as_target="$build" - as_cpu="$build_cpu" ;; -esac -fi ;; -esac + as_cpu="$build_cpu" +fi fi # Finding the assembler @@ -16579,9 +16277,8 @@ then : internal_cflags="$internal_cflags $sharedlib_cflags" default_aspp="$default_aspp $sharedlib_cflags" -else case e in #( - e) fpic=false ;; -esac +else $as_nop + fpic=false fi if test -z "$AS" @@ -16602,8 +16299,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_rlwrap+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$rlwrap"; then +else $as_nop + if test -n "$rlwrap"; then ac_cv_prog_rlwrap="$rlwrap" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -16625,8 +16322,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi rlwrap=$ac_cv_prog_rlwrap if test -n "$rlwrap"; then @@ -16657,18 +16353,16 @@ printf "%s\n" "$as_me: checking semantics of signal handlers" >&6;} if test "x$ac_cv_func_sigaction" = xyes then : has_sigaction=true -else case e in #( - e) has_sigaction=false ;; -esac +else $as_nop + has_sigaction=false fi ac_fn_c_check_func "$LINENO" "sigprocmask" "ac_cv_func_sigprocmask" if test "x$ac_cv_func_sigprocmask" = xyes then : has_sigprocmask=true -else case e in #( - e) has_sigprocmask=false ;; -esac +else $as_nop + has_sigprocmask=false fi if $has_sigaction && $has_sigprocmask @@ -16677,12 +16371,11 @@ then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: POSIX signal handling found." >&5 printf "%s\n" "$as_me: POSIX signal handling found." >&6;} -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: assuming signals have the System V semantics." >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: assuming signals have the System V semantics." >&5 printf "%s\n" "$as_me: assuming signals have the System V semantics." >&6;} - ;; -esac + fi @@ -16692,17 +16385,16 @@ has_c99_float_ops=true for ac_func in expm1 log1p hypot fma exp2 log2 cbrt acosh asinh atanh erf erfc trunc round copysign do : - as_ac_var=`printf "%s\n" "ac_cv_func_$ac_func" | sed "$as_sed_sh"` + as_ac_var=`printf "%s\n" "ac_cv_func_$ac_func" | $as_tr_sh` ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" if eval test \"x\$"$as_ac_var"\" = x"yes" then : cat >>confdefs.h <<_ACEOF -#define `printf "%s\n" "HAVE_$ac_func" | sed "$as_sed_cpp"` 1 +#define `printf "%s\n" "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF -else case e in #( - e) has_c99_float_ops=false ;; -esac +else $as_nop + has_c99_float_ops=false fi done @@ -16733,8 +16425,8 @@ printf "%s\n" "cross-compiling; assume yes" >&6; } printf "%s\n" "#define HAS_WORKING_ROUND 1" >>confdefs.h ;; esac -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include @@ -16750,8 +16442,8 @@ then : printf "%s\n" "yes" >&6; } printf "%s\n" "#define HAS_WORKING_ROUND 1" >>confdefs.h -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } case $enable_imprecise_c99_float_ops,$target in #( no,*) : @@ -16766,16 +16458,13 @@ esac if test x"$hard_error" = "xtrue" then : as_fn_error $? "round does not work, enable emulation with --enable-imprecise-c99-float-ops" "$LINENO" 5 -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: round does not work; emulation enabled" >&5 -printf "%s\n" "$as_me: WARNING: round does not work; emulation enabled" >&2;} ;; -esac -fi ;; -esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: round does not work; emulation enabled" >&5 +printf "%s\n" "$as_me: WARNING: round does not work; emulation enabled" >&2;} +fi fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext ;; -esac + conftest.$ac_objext conftest.beam conftest.$ac_ext fi cross_compiling="$old_cross_compiling" @@ -16804,8 +16493,8 @@ printf "%s\n" "cross-compiling; assume yes" >&6; } printf "%s\n" "#define HAS_WORKING_FMA 1" >>confdefs.h ;; esac -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include @@ -16843,8 +16532,8 @@ then : printf "%s\n" "yes" >&6; } printf "%s\n" "#define HAS_WORKING_FMA 1" >>confdefs.h -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } case $enable_imprecise_c99_float_ops,$target in #( no,*) : @@ -16859,9 +16548,8 @@ printf "%s\n" "no" >&6; } if test "${ocaml_cc_vendor#msvc-}" -lt 1920 then : hard_error=false -else case e in #( - e) hard_error=true ;; -esac +else $as_nop + hard_error=true fi ;; #( *) : hard_error=true ;; @@ -16870,23 +16558,20 @@ esac if test x"$hard_error" = "xtrue" then : as_fn_error $? "fma does not work, enable emulation with --enable-imprecise-c99-float-ops" "$LINENO" 5 -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: fma does not work; emulation enabled" >&5 -printf "%s\n" "$as_me: WARNING: fma does not work; emulation enabled" >&2;} ;; -esac -fi ;; -esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: fma does not work; emulation enabled" >&5 +printf "%s\n" "$as_me: WARNING: fma does not work; emulation enabled" >&2;} +fi fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext ;; -esac + conftest.$ac_objext conftest.beam conftest.$ac_ext fi cross_compiling="$old_cross_compiling" -else case e in #( - e) if test x"$enable_imprecise_c99_float_ops" != "xyes" +else $as_nop + if test x"$enable_imprecise_c99_float_ops" != "xyes" then : case $enable_imprecise_c99_float_ops,$ocaml_cc_vendor in #( no,*) : @@ -16895,9 +16580,8 @@ then : if test "${ocaml_cc_vendor#msvc-}" -lt 1800 then : hard_error=false -else case e in #( - e) hard_error=true ;; -esac +else $as_nop + hard_error=true fi ;; #( *) : hard_error=true ;; @@ -16905,13 +16589,11 @@ esac if test x"$hard_error" = 'xtrue' then : as_fn_error $? "C99 float ops unavailable, enable replacements with --enable-imprecise-c99-float-ops" "$LINENO" 5 -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: C99 float ops unavailable, replacements enabled (ancient Visual Studio)" >&5 -printf "%s\n" "$as_me: WARNING: C99 float ops unavailable, replacements enabled (ancient Visual Studio)" >&2;} ;; -esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: C99 float ops unavailable, replacements enabled (ancient Visual Studio)" >&5 +printf "%s\n" "$as_me: WARNING: C99 float ops unavailable, replacements enabled (ancient Visual Studio)" >&2;} +fi fi -fi ;; -esac fi ## getentropy @@ -16920,8 +16602,8 @@ printf %s "checking for $CC options needed to detect all undeclared functions... if test ${ac_cv_c_undeclared_builtin_options+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_save_CFLAGS=$CFLAGS +else $as_nop + ac_save_CFLAGS=$CFLAGS ac_cv_c_undeclared_builtin_options='cannot detect' for ac_arg in '' -fno-builtin; do CFLAGS="$ac_save_CFLAGS $ac_arg" @@ -16940,8 +16622,8 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : -else case e in #( - e) # This test program should compile successfully. +else $as_nop + # This test program should compile successfully. # No library function is consistently available on # freestanding implementations, so test against a dummy # declaration. Include always-available headers on the @@ -16969,29 +16651,26 @@ then : if test x"$ac_arg" = x then : ac_cv_c_undeclared_builtin_options='none needed' -else case e in #( - e) ac_cv_c_undeclared_builtin_options=$ac_arg ;; -esac +else $as_nop + ac_cv_c_undeclared_builtin_options=$ac_arg fi break fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; -esac +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext done CFLAGS=$ac_save_CFLAGS - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_undeclared_builtin_options" >&5 printf "%s\n" "$ac_cv_c_undeclared_builtin_options" >&6; } case $ac_cv_c_undeclared_builtin_options in #( 'cannot detect') : - { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in '$ac_pwd':" >&5 -printf "%s\n" "$as_me: error: in '$ac_pwd':" >&2;} + { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot make $CC report undeclared builtins -See 'config.log' for more details" "$LINENO" 5; } ;; #( +See \`config.log' for more details" "$LINENO" 5; } ;; #( 'none needed') : ac_c_undeclared_builtin_options='' ;; #( *) : @@ -17039,15 +16718,14 @@ if test "x$ac_cv_func_secure_getenv" = xyes then : printf "%s\n" "#define HAS_SECURE_GETENV 1" >>confdefs.h -else case e in #( - e) ac_fn_c_check_func "$LINENO" "__secure_getenv" "ac_cv_func___secure_getenv" +else $as_nop + ac_fn_c_check_func "$LINENO" "__secure_getenv" "ac_cv_func___secure_getenv" if test "x$ac_cv_func___secure_getenv" = xyes then : printf "%s\n" "#define HAS___SECURE_GETENV 1" >>confdefs.h fi - ;; -esac + fi @@ -17087,9 +16765,8 @@ then : printf "%s\n" "#define HAS_CLOCK_GETTIME_NSEC_NP 1" >>confdefs.h -else case e in #( - e) has_monotonic_clock=false ;; -esac +else $as_nop + has_monotonic_clock=false fi done ;; #( @@ -17116,9 +16793,8 @@ then : printf "%s\n" "#define HAS_POSIX_MONOTONIC_CLOCK 1" >>confdefs.h -else case e in #( - e) has_monotonic_clock=false ;; -esac +else $as_nop + has_monotonic_clock=false fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext @@ -17156,21 +16832,15 @@ printf %s "checking for library containing clock_gettime... " >&6; } if test ${ac_cv_search_clock_gettime+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_func_search_save_LIBS=$LIBS +else $as_nop + ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. - The 'extern "C"' is for builds by C++ compilers; - although this is not generally supported in C code supporting it here - has little cost and some practical benefit (sr 110532). */ -#ifdef __cplusplus -extern "C" -#endif -char clock_gettime (void); + builtin and then its argument prototype would still apply. */ +char clock_gettime (); int main (void) { @@ -17201,13 +16871,11 @@ done if test ${ac_cv_search_clock_gettime+y} then : -else case e in #( - e) ac_cv_search_clock_gettime=no ;; -esac +else $as_nop + ac_cv_search_clock_gettime=no fi rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS ;; -esac +LIBS=$ac_func_search_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_clock_gettime" >&5 printf "%s\n" "$ac_cv_search_clock_gettime" >&6; } @@ -17216,9 +16884,8 @@ if test "$ac_res" != no then : test "$ac_res" = "none required" || LIBS="$ac_res $LIBS" has_clock_gettime=true -else case e in #( - e) has_clock_gettime=false ;; -esac +else $as_nop + has_clock_gettime=false fi case $enable_instrumented_runtime,$has_clock_gettime,$has_monotonic_clock in #( @@ -17232,10 +16899,9 @@ fi if test "x$ac_cv_search_clock_gettime" = "xnone required" then : instrumented_runtime_libs="" -else case e in #( - e) instrumented_runtime_libs=$ac_cv_search_clock_gettime - ;; -esac +else $as_nop + instrumented_runtime_libs=$ac_cv_search_clock_gettime + fi ;; #( yes,false,*) : @@ -17330,9 +16996,8 @@ esac ;; #( as_fn_error $? "thread sanitizer not supported on arch $arch" "$LINENO" 5 ;; esac -else case e in #( - e) tsan=false ;; -esac +else $as_nop + tsan=false fi if $tsan @@ -17357,10 +17022,9 @@ _ACEOF if ac_fn_c_try_link "$LINENO" then : -else case e in #( - e) as_fn_error $? "libtsan is necessary for TSan but cannot be found. - Try installing it on your system." "$LINENO" 5 ;; -esac +else $as_nop + as_fn_error $? "libtsan is necessary for TSan but cannot be found. + Try installing it on your system." "$LINENO" 5 fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext @@ -17380,14 +17044,14 @@ esac *) : ;; esac - as_CACHEVAR=`printf "%s\n" "ax_cv_check_cflags_$warn_error_flag_-fsanitize=thread $tsan_distinguish_volatile_cflags" | sed "$as_sed_sh"` + as_CACHEVAR=`printf "%s\n" "ax_cv_check_cflags_$warn_error_flag_-fsanitize=thread $tsan_distinguish_volatile_cflags" | $as_tr_sh` { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether C compiler accepts -fsanitize=thread $tsan_distinguish_volatile_cflags" >&5 printf %s "checking whether C compiler accepts -fsanitize=thread $tsan_distinguish_volatile_cflags... " >&6; } if eval test \${$as_CACHEVAR+y} then : printf %s "(cached) " >&6 -else case e in #( - e) +else $as_nop + ax_check_save_flags=$CFLAGS CFLAGS="$CFLAGS $warn_error_flag -fsanitize=thread $tsan_distinguish_volatile_cflags" cat confdefs.h - <<_ACEOF >conftest.$ac_ext @@ -17404,13 +17068,11 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : eval "$as_CACHEVAR=yes" -else case e in #( - e) eval "$as_CACHEVAR=no" ;; -esac +else $as_nop + eval "$as_CACHEVAR=no" fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext - CFLAGS=$ax_check_save_flags ;; -esac + CFLAGS=$ax_check_save_flags fi eval ac_res=\$$as_CACHEVAR { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 @@ -17418,9 +17080,8 @@ printf "%s\n" "$ac_res" >&6; } if eval test \"x\$"$as_CACHEVAR"\" = x"yes" then : : -else case e in #( - e) as_fn_error $? "The C compiler does not support the \`$tsan_distinguish_volatile_cflags' flag. Try upgrading to GCC >= 11, or to Clang >= 11." "$LINENO" 5 ;; -esac +else $as_nop + as_fn_error $? "The C compiler does not support the \`$tsan_distinguish_volatile_cflags' flag. Try upgrading to GCC >= 11, or to Clang >= 11." "$LINENO" 5 fi oc_tsan_cflags="$oc_tsan_cflags $tsan_distinguish_volatile_cflags" @@ -17428,12 +17089,11 @@ fi native_cflags="$native_cflags $oc_tsan_cflags" ocamlc_cflags="$ocamlc_cflags $oc_tsan_cflags" tsan_native_runtime_c_sources="tsan" -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: not using thread sanitizer" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: not using thread sanitizer" >&5 printf "%s\n" "$as_me: not using thread sanitizer" >&6;} tsan_native_runtime_c_sources="" - ;; -esac + fi # libunwind detection when TSan is enabled @@ -17455,9 +17115,8 @@ fi if test x"$LIBUNWIND_CPPFLAGS" != x then : libunwind_cppflags="$LIBUNWIND_CPPFLAGS" -else case e in #( - e) libunwind_cppflags="" ;; -esac +else $as_nop + libunwind_cppflags="" fi case "$system" in #( @@ -17501,9 +17160,8 @@ then : printf "%s\n" "#define HAS_LIBUNWIND 1" >>confdefs.h libunwind_available=true -else case e in #( - e) libunwind_available=false ;; -esac +else $as_nop + libunwind_available=false fi LDFLAGS="$SAVED_LDFLAGS" @@ -17543,21 +17201,15 @@ printf %s "checking for library containing socket... " >&6; } if test ${ac_cv_search_socket+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_func_search_save_LIBS=$LIBS +else $as_nop + ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. - The 'extern "C"' is for builds by C++ compilers; - although this is not generally supported in C code supporting it here - has little cost and some practical benefit (sr 110532). */ -#ifdef __cplusplus -extern "C" -#endif -char socket (void); + builtin and then its argument prototype would still apply. */ +char socket (); int main (void) { @@ -17588,13 +17240,11 @@ done if test ${ac_cv_search_socket+y} then : -else case e in #( - e) ac_cv_search_socket=no ;; -esac +else $as_nop + ac_cv_search_socket=no fi rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS ;; -esac +LIBS=$ac_func_search_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_socket" >&5 printf "%s\n" "$ac_cv_search_socket" >&6; } @@ -17619,21 +17269,15 @@ printf %s "checking for library containing socket... " >&6; } if test ${ac_cv_search_socket+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_func_search_save_LIBS=$LIBS +else $as_nop + ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. - The 'extern "C"' is for builds by C++ compilers; - although this is not generally supported in C code supporting it here - has little cost and some practical benefit (sr 110532). */ -#ifdef __cplusplus -extern "C" -#endif -char socket (void); + builtin and then its argument prototype would still apply. */ +char socket (); int main (void) { @@ -17664,13 +17308,11 @@ done if test ${ac_cv_search_socket+y} then : -else case e in #( - e) ac_cv_search_socket=no ;; -esac +else $as_nop + ac_cv_search_socket=no fi rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS ;; -esac +LIBS=$ac_func_search_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_socket" >&5 printf "%s\n" "$ac_cv_search_socket" >&6; } @@ -17695,21 +17337,15 @@ printf %s "checking for library containing socket... " >&6; } if test ${ac_cv_search_socket+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_func_search_save_LIBS=$LIBS +else $as_nop + ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. - The 'extern "C"' is for builds by C++ compilers; - although this is not generally supported in C code supporting it here - has little cost and some practical benefit (sr 110532). */ -#ifdef __cplusplus -extern "C" -#endif -char socket (void); + builtin and then its argument prototype would still apply. */ +char socket (); int main (void) { @@ -17740,13 +17376,11 @@ done if test ${ac_cv_search_socket+y} then : -else case e in #( - e) ac_cv_search_socket=no ;; -esac +else $as_nop + ac_cv_search_socket=no fi rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS ;; -esac +LIBS=$ac_func_search_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_socket" >&5 printf "%s\n" "$ac_cv_search_socket" >&6; } @@ -17764,21 +17398,15 @@ printf %s "checking for library containing socket... " >&6; } if test ${ac_cv_search_socket+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_func_search_save_LIBS=$LIBS +else $as_nop + ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. - The 'extern "C"' is for builds by C++ compilers; - although this is not generally supported in C code supporting it here - has little cost and some practical benefit (sr 110532). */ -#ifdef __cplusplus -extern "C" -#endif -char socket (void); + builtin and then its argument prototype would still apply. */ +char socket (); int main (void) { @@ -17809,13 +17437,11 @@ done if test ${ac_cv_search_socket+y} then : -else case e in #( - e) ac_cv_search_socket=no ;; -esac +else $as_nop + ac_cv_search_socket=no fi rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS ;; -esac +LIBS=$ac_func_search_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_socket" >&5 printf "%s\n" "$ac_cv_search_socket" >&6; } @@ -17831,21 +17457,15 @@ printf %s "checking for library containing inet_ntop... " >&6; } if test ${ac_cv_search_inet_ntop+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_func_search_save_LIBS=$LIBS +else $as_nop + ac_func_search_save_LIBS=$LIBS cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. - The 'extern "C"' is for builds by C++ compilers; - although this is not generally supported in C code supporting it here - has little cost and some practical benefit (sr 110532). */ -#ifdef __cplusplus -extern "C" -#endif -char inet_ntop (void); + builtin and then its argument prototype would still apply. */ +char inet_ntop (); int main (void) { @@ -17876,13 +17496,11 @@ done if test ${ac_cv_search_inet_ntop+y} then : -else case e in #( - e) ac_cv_search_inet_ntop=no ;; -esac +else $as_nop + ac_cv_search_inet_ntop=no fi rm conftest.$ac_ext -LIBS=$ac_func_search_save_LIBS ;; -esac +LIBS=$ac_func_search_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_search_inet_ntop" >&5 printf "%s\n" "$ac_cv_search_inet_ntop" >&6; } @@ -17898,17 +17516,16 @@ fi for ac_func in socket socketpair bind listen accept connect do : - as_ac_var=`printf "%s\n" "ac_cv_func_$ac_func" | sed "$as_sed_sh"` + as_ac_var=`printf "%s\n" "ac_cv_func_$ac_func" | $as_tr_sh` ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" if eval test \"x\$"$as_ac_var"\" = x"yes" then : cat >>confdefs.h <<_ACEOF -#define `printf "%s\n" "HAVE_$ac_func" | sed "$as_sed_cpp"` 1 +#define `printf "%s\n" "HAVE_$ac_func" | $as_tr_cpp` 1 _ACEOF -else case e in #( - e) sockets=false ;; -esac +else $as_nop + sockets=false fi done @@ -17984,9 +17601,8 @@ case $host in #( if test "x$ac_cv_type_struct_sockaddr_in6" = xyes then : -else case e in #( - e) ipv6=false ;; -esac +else $as_nop + ipv6=false fi ;; #( *) : @@ -18000,9 +17616,8 @@ fi if test "x$ac_cv_type_struct_sockaddr_in6" = xyes then : -else case e in #( - e) ipv6=false ;; -esac +else $as_nop + ipv6=false fi ;; @@ -18014,9 +17629,8 @@ then : if test "x$ac_cv_func_getaddrinfo" = xyes then : -else case e in #( - e) ipv6=false ;; -esac +else $as_nop + ipv6=false fi fi @@ -18027,9 +17641,8 @@ then : if test "x$ac_cv_func_getnameinfo" = xyes then : -else case e in #( - e) ipv6=false ;; -esac +else $as_nop + ipv6=false fi fi @@ -18040,9 +17653,8 @@ then : if test "x$ac_cv_func_inet_pton" = xyes then : -else case e in #( - e) ipv6=false ;; -esac +else $as_nop + ipv6=false fi fi @@ -18174,9 +17786,8 @@ then : printf "%s\n" "#define HAS_SELECT 1" >>confdefs.h select=true -else case e in #( - e) select=false ;; -esac +else $as_nop + select=false fi fi @@ -18225,9 +17836,8 @@ then : printf "%s\n" "#define HAS_WAITPID 1" >>confdefs.h -else case e in #( - e) wait=false ;; -esac +else $as_nop + wait=false fi @@ -18314,9 +17924,8 @@ then : printf "%s\n" "#define HAS_SETITIMER 1" >>confdefs.h -else case e in #( - e) setitimer=false ;; -esac +else $as_nop + setitimer=false fi @@ -18362,9 +17971,8 @@ then : printf "%s\n" "#define HAS_GETTIMEOFDAY 1" >>confdefs.h -else case e in #( - e) gettimeofday=false ;; -esac +else $as_nop + gettimeofday=false fi @@ -18501,28 +18109,22 @@ then : if test "x$ac_cv_func_dlopen" = xyes then : supports_shared_libraries=true DLLIBS="" -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 printf %s "checking for dlopen in -ldl... " >&6; } if test ${ac_cv_lib_dl_dlopen+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_check_lib_save_LIBS=$LIBS +else $as_nop + ac_check_lib_save_LIBS=$LIBS LIBS="-ldl $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. - The 'extern "C"' is for builds by C++ compilers; - although this is not generally supported in C code supporting it here - has little cost and some practical benefit (sr 110532). */ -#ifdef __cplusplus -extern "C" -#endif -char dlopen (void); + builtin and then its argument prototype would still apply. */ +char dlopen (); int main (void) { @@ -18534,32 +18136,27 @@ _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_dl_dlopen=yes -else case e in #( - e) ac_cv_lib_dl_dlopen=no ;; -esac +else $as_nop + ac_cv_lib_dl_dlopen=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS ;; -esac +LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 printf "%s\n" "$ac_cv_lib_dl_dlopen" >&6; } if test "x$ac_cv_lib_dl_dlopen" = xyes then : supports_shared_libraries=true DLLIBS="-ldl $DLLIBS" -else case e in #( - e) supports_shared_libraries=false ;; -esac +else $as_nop + supports_shared_libraries=false fi - ;; -esac + fi ;; esac -else case e in #( - e) supports_shared_libraries=false ;; -esac +else $as_nop + supports_shared_libraries=false fi if $supports_shared_libraries @@ -18568,10 +18165,9 @@ then : printf "%s\n" "$as_me: Dynamic loading of shared libraries is supported." >&6;} printf "%s\n" "#define SUPPORT_DYNAMIC_LINKING 1" >>confdefs.h -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Dynamic loading of shared libraries is not supported." >&5 -printf "%s\n" "$as_me: Dynamic loading of shared libraries is not supported." >&6;} ;; -esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Dynamic loading of shared libraries is not supported." >&5 +printf "%s\n" "$as_me: Dynamic loading of shared libraries is not supported." >&6;} fi ## mmap @@ -18629,11 +18225,10 @@ then : cc_has_debug_prefix_map=true { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } -else case e in #( - e) cc_has_debug_prefix_map=false +else $as_nop + cc_has_debug_prefix_map=false { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } ;; -esac +printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext CFLAGS="$saved_CFLAGS" @@ -18694,10 +18289,9 @@ if $stat_has_ns_precision then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: stat supports nanosecond precision" >&5 printf "%s\n" "$as_me: stat supports nanosecond precision" >&6;} -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: stat does not support nanosecond precision" >&5 -printf "%s\n" "$as_me: stat does not support nanosecond precision" >&6;} ;; -esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: stat does not support nanosecond precision" >&5 +printf "%s\n" "$as_me: stat does not support nanosecond precision" >&6;} fi # Number of arguments of gethostbyname_r @@ -18716,8 +18310,8 @@ printf %s "checking how many arguments gethostbyname_r() takes... " >&6; } if test ${ac_cv_func_which_gethostbyname_r+y} then : printf %s "(cached) " >&6 -else case e in #( - e) +else $as_nop + ################################################################ @@ -18851,8 +18445,7 @@ fi ################################################################ - ;; -esac + fi case "$ac_cv_func_which_gethostbyname_r" in @@ -18942,8 +18535,8 @@ printf %s "checking how many arguments gethostbyaddr_r() takes... " >&6; } if test ${ac_cv_func_which_gethostbyaddr_r+y} then : printf %s "(cached) " >&6 -else case e in #( - e) +else $as_nop + ################################################################ @@ -19048,8 +18641,7 @@ fi ################################################################ - ;; -esac + fi case "$ac_cv_func_which_gethostbyaddr_r" in @@ -19238,8 +18830,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_path_PKG_CONFIG+y} then : printf %s "(cached) " >&6 -else case e in #( - e) case $PKG_CONFIG in +else $as_nop + case $PKG_CONFIG in [\\/]* | ?:[\\/]*) ac_cv_path_PKG_CONFIG="$PKG_CONFIG" # Let the user override the test with a path. ;; @@ -19264,7 +18856,6 @@ done IFS=$as_save_IFS ;; -esac ;; esac fi PKG_CONFIG=$ac_cv_path_PKG_CONFIG @@ -19287,8 +18878,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_path_ac_pt_PKG_CONFIG+y} then : printf %s "(cached) " >&6 -else case e in #( - e) case $ac_pt_PKG_CONFIG in +else $as_nop + case $ac_pt_PKG_CONFIG in [\\/]* | ?:[\\/]*) ac_cv_path_ac_pt_PKG_CONFIG="$ac_pt_PKG_CONFIG" # Let the user override the test with a path. ;; @@ -19313,7 +18904,6 @@ done IFS=$as_save_IFS ;; -esac ;; esac fi ac_pt_PKG_CONFIG=$ac_cv_path_ac_pt_PKG_CONFIG @@ -19366,8 +18956,8 @@ then : printf "%s\n" "gnu" >&6; } printf "%s\n" "#define HAS_GNU_GETAFFINITY_NP 1" >>confdefs.h -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include @@ -19390,14 +18980,12 @@ then : printf "%s\n" "BSD" >&6; } printf "%s\n" "#define HAS_BSD_GETAFFINITY_NP 1" >>confdefs.h -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: pthread_getaffinity_np not found" >&5 -printf "%s\n" "pthread_getaffinity_np not found" >&6; } ;; -esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: pthread_getaffinity_np not found" >&5 +printf "%s\n" "pthread_getaffinity_np not found" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext conftest.$ac_ext ;; -esac + conftest$ac_exeext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext @@ -19410,8 +18998,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_path_PKG_CONFIG+y} then : printf %s "(cached) " >&6 -else case e in #( - e) case $PKG_CONFIG in +else $as_nop + case $PKG_CONFIG in [\\/]* | ?:[\\/]*) ac_cv_path_PKG_CONFIG="$PKG_CONFIG" # Let the user override the test with a path. ;; @@ -19436,7 +19024,6 @@ done IFS=$as_save_IFS ;; -esac ;; esac fi PKG_CONFIG=$ac_cv_path_PKG_CONFIG @@ -19459,8 +19046,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_path_ac_pt_PKG_CONFIG+y} then : printf %s "(cached) " >&6 -else case e in #( - e) case $ac_pt_PKG_CONFIG in +else $as_nop + case $ac_pt_PKG_CONFIG in [\\/]* | ?:[\\/]*) ac_cv_path_ac_pt_PKG_CONFIG="$ac_pt_PKG_CONFIG" # Let the user override the test with a path. ;; @@ -19485,7 +19072,6 @@ done IFS=$as_save_IFS ;; -esac ;; esac fi ac_pt_PKG_CONFIG=$ac_cv_path_ac_pt_PKG_CONFIG @@ -19529,34 +19115,27 @@ then : zstd_libs=`${PKG_CONFIG} --libs libzstd` zstd_flags=`${PKG_CONFIG} --cflags libzstd` zstd_status="ok" -else case e in #( - e) zstd_status="zstd library too old: version 1.4 or later is needed" ;; -esac +else $as_nop + zstd_status="zstd library too old: version 1.4 or later is needed" fi -else case e in #( - e) # Otherwise, try to find zstd the old way, +else $as_nop + # Otherwise, try to find zstd the old way, # assuming it is installed in default places { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ZSTD_createCCtx in -lzstd" >&5 printf %s "checking for ZSTD_createCCtx in -lzstd... " >&6; } if test ${ac_cv_lib_zstd_ZSTD_createCCtx+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ac_check_lib_save_LIBS=$LIBS +else $as_nop + ac_check_lib_save_LIBS=$LIBS LIBS="-lzstd $LIBS" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. - The 'extern "C"' is for builds by C++ compilers; - although this is not generally supported in C code supporting it here - has little cost and some practical benefit (sr 110532). */ -#ifdef __cplusplus -extern "C" -#endif -char ZSTD_createCCtx (void); + builtin and then its argument prototype would still apply. */ +char ZSTD_createCCtx (); int main (void) { @@ -19568,14 +19147,12 @@ _ACEOF if ac_fn_c_try_link "$LINENO" then : ac_cv_lib_zstd_ZSTD_createCCtx=yes -else case e in #( - e) ac_cv_lib_zstd_ZSTD_createCCtx=no ;; -esac +else $as_nop + ac_cv_lib_zstd_ZSTD_createCCtx=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext -LIBS=$ac_check_lib_save_LIBS ;; -esac +LIBS=$ac_check_lib_save_LIBS fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_zstd_ZSTD_createCCtx" >&5 printf "%s\n" "$ac_cv_lib_zstd_ZSTD_createCCtx" >&6; } @@ -19588,16 +19165,13 @@ then : zstd_libs="-lzstd" zstd_flags="" zstd_status="ok" -else case e in #( - e) zstd_status="zstd library too old: version 1.4 or later is needed" ;; -esac +else $as_nop + zstd_status="zstd library too old: version 1.4 or later is needed" fi -else case e in #( - e) zstd_status="zstd library not found" ;; -esac +else $as_nop + zstd_status="zstd library not found" fi - ;; -esac + fi fi @@ -19652,27 +19226,24 @@ then : then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } zstd_libs='' zstd_flags='' zstd_status=\ -"programs linked with zstd do not appear to be executable." ;; -esac +"programs linked with zstd do not appear to be executable." fi -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: skipped" >&5 -printf "%s\n" "skipped" >&6; } ;; -esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: skipped" >&5 +printf "%s\n" "skipped" >&6; } fi -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } zstd_libs='' zstd_flags='' - zstd_status="zstd found, but programs cannot be linked with it." ;; -esac + zstd_status="zstd found, but programs cannot be linked with it." fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext @@ -19695,8 +19266,8 @@ printf "%s\n" "$as_me: compressed compilation artefacts supported" >&6;} internal_cppflags="$internal_cppflags $zstd_flags" printf "%s\n" "#define HAS_ZSTD 1" >>confdefs.h -else case e in #( - e) case "$with_zstd" in #( +else $as_nop + case "$with_zstd" in #( no) : ;; #( yes) : @@ -19706,7 +19277,6 @@ else case e in #( printf "%s\n" "$as_me: WARNING: $zstd_status" >&2;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: compressed compilation artefacts not supported" >&5 printf "%s\n" "$as_me: WARNING: compressed compilation artefacts not supported" >&2;} ;; -esac ;; esac fi @@ -19726,12 +19296,11 @@ then : optional_bytecode_tools="$optional_bytecode_tools debugger/ocamldebug" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: ocamldebug supported" >&5 printf "%s\n" "$as_me: ocamldebug supported" >&6;} -else case e in #( - e) with_debugger="" +else $as_nop + with_debugger="" build_ocamldebug=false { printf "%s\n" "$as_me:${as_lineno-$LINENO}: ocamldebug not supported" >&5 -printf "%s\n" "$as_me: ocamldebug not supported" >&6;} ;; -esac +printf "%s\n" "$as_me: ocamldebug not supported" >&6;} fi ;; esac @@ -19763,140 +19332,6 @@ esac ## Determine how to link with the POSIX threads library -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for egrep -e" >&5 -printf %s "checking for egrep -e... " >&6; } -if test ${ac_cv_path_EGREP_TRADITIONAL+y} -then : - printf %s "(cached) " >&6 -else case e in #( - e) if test -z "$EGREP_TRADITIONAL"; then - ac_path_EGREP_TRADITIONAL_found=false - # Loop through the user's path and test for each of PROGNAME-LIST - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - for ac_prog in grep ggrep - do - for ac_exec_ext in '' $ac_executable_extensions; do - ac_path_EGREP_TRADITIONAL="$as_dir$ac_prog$ac_exec_ext" - as_fn_executable_p "$ac_path_EGREP_TRADITIONAL" || continue -# Check for GNU ac_path_EGREP_TRADITIONAL and select it if it is found. - # Check for GNU $ac_path_EGREP_TRADITIONAL -case `"$ac_path_EGREP_TRADITIONAL" --version 2>&1` in #( -*GNU*) - ac_cv_path_EGREP_TRADITIONAL="$ac_path_EGREP_TRADITIONAL" ac_path_EGREP_TRADITIONAL_found=:;; -#( -*) - ac_count=0 - printf %s 0123456789 >"conftest.in" - while : - do - cat "conftest.in" "conftest.in" >"conftest.tmp" - mv "conftest.tmp" "conftest.in" - cp "conftest.in" "conftest.nl" - printf "%s\n" 'EGREP_TRADITIONAL' >> "conftest.nl" - "$ac_path_EGREP_TRADITIONAL" -E 'EGR(EP|AC)_TRADITIONAL$' < "conftest.nl" >"conftest.out" 2>/dev/null || break - diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break - as_fn_arith $ac_count + 1 && ac_count=$as_val - if test $ac_count -gt ${ac_path_EGREP_TRADITIONAL_max-0}; then - # Best one so far, save it but keep looking for a better one - ac_cv_path_EGREP_TRADITIONAL="$ac_path_EGREP_TRADITIONAL" - ac_path_EGREP_TRADITIONAL_max=$ac_count - fi - # 10*(2^10) chars as input seems more than enough - test $ac_count -gt 10 && break - done - rm -f conftest.in conftest.tmp conftest.nl conftest.out;; -esac - - $ac_path_EGREP_TRADITIONAL_found && break 3 - done - done - done -IFS=$as_save_IFS - if test -z "$ac_cv_path_EGREP_TRADITIONAL"; then - : - fi -else - ac_cv_path_EGREP_TRADITIONAL=$EGREP_TRADITIONAL -fi - - if test "$ac_cv_path_EGREP_TRADITIONAL" -then : - ac_cv_path_EGREP_TRADITIONAL="$ac_cv_path_EGREP_TRADITIONAL -E" -else case e in #( - e) if test -z "$EGREP_TRADITIONAL"; then - ac_path_EGREP_TRADITIONAL_found=false - # Loop through the user's path and test for each of PROGNAME-LIST - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin -do - IFS=$as_save_IFS - case $as_dir in #((( - '') as_dir=./ ;; - */) ;; - *) as_dir=$as_dir/ ;; - esac - for ac_prog in egrep - do - for ac_exec_ext in '' $ac_executable_extensions; do - ac_path_EGREP_TRADITIONAL="$as_dir$ac_prog$ac_exec_ext" - as_fn_executable_p "$ac_path_EGREP_TRADITIONAL" || continue -# Check for GNU ac_path_EGREP_TRADITIONAL and select it if it is found. - # Check for GNU $ac_path_EGREP_TRADITIONAL -case `"$ac_path_EGREP_TRADITIONAL" --version 2>&1` in #( -*GNU*) - ac_cv_path_EGREP_TRADITIONAL="$ac_path_EGREP_TRADITIONAL" ac_path_EGREP_TRADITIONAL_found=:;; -#( -*) - ac_count=0 - printf %s 0123456789 >"conftest.in" - while : - do - cat "conftest.in" "conftest.in" >"conftest.tmp" - mv "conftest.tmp" "conftest.in" - cp "conftest.in" "conftest.nl" - printf "%s\n" 'EGREP_TRADITIONAL' >> "conftest.nl" - "$ac_path_EGREP_TRADITIONAL" 'EGR(EP|AC)_TRADITIONAL$' < "conftest.nl" >"conftest.out" 2>/dev/null || break - diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break - as_fn_arith $ac_count + 1 && ac_count=$as_val - if test $ac_count -gt ${ac_path_EGREP_TRADITIONAL_max-0}; then - # Best one so far, save it but keep looking for a better one - ac_cv_path_EGREP_TRADITIONAL="$ac_path_EGREP_TRADITIONAL" - ac_path_EGREP_TRADITIONAL_max=$ac_count - fi - # 10*(2^10) chars as input seems more than enough - test $ac_count -gt 10 && break - done - rm -f conftest.in conftest.tmp conftest.nl conftest.out;; -esac - - $ac_path_EGREP_TRADITIONAL_found && break 3 - done - done - done -IFS=$as_save_IFS - if test -z "$ac_cv_path_EGREP_TRADITIONAL"; then - as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 - fi -else - ac_cv_path_EGREP_TRADITIONAL=$EGREP_TRADITIONAL -fi - ;; -esac -fi ;; -esac -fi -{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP_TRADITIONAL" >&5 -printf "%s\n" "$ac_cv_path_EGREP_TRADITIONAL" >&6; } - EGREP_TRADITIONAL=$ac_cv_path_EGREP_TRADITIONAL - case $host in #( *-*-mingw32*) : PTHREAD_LIBS="-l:libpthread.a -lgcc_eh" ;; #( @@ -19945,14 +19380,8 @@ printf %s "checking for pthread_join using $CC $PTHREAD_CFLAGS $PTHREAD_LIBS... /* Override any GCC internal prototype to avoid an error. Use char because int might match the return type of a GCC - builtin and then its argument prototype would still apply. - The 'extern "C"' is for builds by C++ compilers; - although this is not generally supported in C code supporting it here - has little cost and some practical benefit (sr 110532). */ -#ifdef __cplusplus -extern "C" -#endif -char pthread_join (void); + builtin and then its argument prototype would still apply. */ +char pthread_join (); int main (void) { @@ -20046,7 +19475,7 @@ case $host_os in _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP_TRADITIONAL "AX_PTHREAD_ZOS_MISSING" >/dev/null 2>&1 + $EGREP "AX_PTHREAD_ZOS_MISSING" >/dev/null 2>&1 then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: IBM z/OS requires -D_OPEN_THREADS or -D_UNIX03_THREADS to enable pthreads support." >&5 printf "%s\n" "$as_me: WARNING: IBM z/OS requires -D_OPEN_THREADS or -D_UNIX03_THREADS to enable pthreads support." >&2;} @@ -20076,8 +19505,8 @@ printf %s "checking whether $CC is Clang... " >&6; } if test ${ax_cv_PTHREAD_CLANG+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ax_cv_PTHREAD_CLANG=no +else $as_nop + ax_cv_PTHREAD_CLANG=no # Note that Autoconf sets GCC=yes for Clang as well as GCC if test "x$GCC" = "xyes"; then cat confdefs.h - <<_ACEOF >conftest.$ac_ext @@ -20089,15 +19518,14 @@ else case e in #( _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | - $EGREP_TRADITIONAL "AX_PTHREAD_CC_IS_CLANG" >/dev/null 2>&1 + $EGREP "AX_PTHREAD_CC_IS_CLANG" >/dev/null 2>&1 then : ax_cv_PTHREAD_CLANG=yes fi rm -rf conftest* fi - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ax_cv_PTHREAD_CLANG" >&5 printf "%s\n" "$ax_cv_PTHREAD_CLANG" >&6; } @@ -20147,9 +19575,8 @@ esac if test "x$ax_pthread_check_macro" = "x--" then : ax_pthread_check_cond=0 -else case e in #( - e) ax_pthread_check_cond="!defined($ax_pthread_check_macro)" ;; -esac +else $as_nop + ax_pthread_check_cond="!defined($ax_pthread_check_macro)" fi @@ -20183,8 +19610,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ax_pthread_config+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$ax_pthread_config"; then +else $as_nop + if test -n "$ax_pthread_config"; then ac_cv_prog_ax_pthread_config="$ax_pthread_config" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -20207,8 +19634,7 @@ done IFS=$as_save_IFS test -z "$ac_cv_prog_ax_pthread_config" && ac_cv_prog_ax_pthread_config="no" -fi ;; -esac +fi fi ax_pthread_config=$ac_cv_prog_ax_pthread_config if test -n "$ax_pthread_config"; then @@ -20341,8 +19767,8 @@ printf %s "checking whether Clang needs flag to prevent \"argument unused\" warn if test ${ax_cv_PTHREAD_CLANG_NO_WARN_FLAG+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ax_cv_PTHREAD_CLANG_NO_WARN_FLAG=unknown +else $as_nop + ax_cv_PTHREAD_CLANG_NO_WARN_FLAG=unknown # Create an alternate version of $ac_link that compiles and # links in two steps (.c -> .o, .o -> exe) instead of one # (.c -> exe), because the warning occurs only in the second @@ -20388,8 +19814,7 @@ then : ax_pthread_try=no fi ax_cv_PTHREAD_CLANG_NO_WARN_FLAG="$ax_pthread_try" - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ax_cv_PTHREAD_CLANG_NO_WARN_FLAG" >&5 printf "%s\n" "$ax_cv_PTHREAD_CLANG_NO_WARN_FLAG" >&6; } @@ -20416,8 +19841,8 @@ printf %s "checking for joinable pthread attribute... " >&6; } if test ${ax_cv_PTHREAD_JOINABLE_ATTR+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ax_cv_PTHREAD_JOINABLE_ATTR=unknown +else $as_nop + ax_cv_PTHREAD_JOINABLE_ATTR=unknown for ax_pthread_attr in PTHREAD_CREATE_JOINABLE PTHREAD_CREATE_UNDETACHED; do cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -20437,8 +19862,7 @@ fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext done - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ax_cv_PTHREAD_JOINABLE_ATTR" >&5 printf "%s\n" "$ax_cv_PTHREAD_JOINABLE_ATTR" >&6; } @@ -20458,15 +19882,14 @@ printf %s "checking whether more special flags are required for pthreads... " >& if test ${ax_cv_PTHREAD_SPECIAL_FLAGS+y} then : printf %s "(cached) " >&6 -else case e in #( - e) ax_cv_PTHREAD_SPECIAL_FLAGS=no +else $as_nop + ax_cv_PTHREAD_SPECIAL_FLAGS=no case $host_os in solaris*) ax_cv_PTHREAD_SPECIAL_FLAGS="-D_POSIX_PTHREAD_SEMANTICS" ;; esac - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ax_cv_PTHREAD_SPECIAL_FLAGS" >&5 printf "%s\n" "$ax_cv_PTHREAD_SPECIAL_FLAGS" >&6; } @@ -20482,8 +19905,8 @@ printf %s "checking for PTHREAD_PRIO_INHERIT... " >&6; } if test ${ax_cv_PTHREAD_PRIO_INHERIT+y} then : printf %s "(cached) " >&6 -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int @@ -20498,14 +19921,12 @@ _ACEOF if ac_fn_c_try_link "$LINENO" then : ax_cv_PTHREAD_PRIO_INHERIT=yes -else case e in #( - e) ax_cv_PTHREAD_PRIO_INHERIT=no ;; -esac +else $as_nop + ax_cv_PTHREAD_PRIO_INHERIT=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext - ;; -esac + fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ax_cv_PTHREAD_PRIO_INHERIT" >&5 printf "%s\n" "$ax_cv_PTHREAD_PRIO_INHERIT" >&6; } @@ -20555,8 +19976,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_PTHREAD_CC+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$PTHREAD_CC"; then +else $as_nop + if test -n "$PTHREAD_CC"; then ac_cv_prog_PTHREAD_CC="$PTHREAD_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -20578,8 +19999,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi PTHREAD_CC=$ac_cv_prog_PTHREAD_CC if test -n "$PTHREAD_CC"; then @@ -20606,8 +20026,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_PTHREAD_CXX+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$PTHREAD_CXX"; then +else $as_nop + if test -n "$PTHREAD_CXX"; then ac_cv_prog_PTHREAD_CXX="$PTHREAD_CXX" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -20629,8 +20049,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi PTHREAD_CXX=$ac_cv_prog_PTHREAD_CXX if test -n "$PTHREAD_CXX"; then @@ -20724,8 +20143,8 @@ then : printf "%s\n" "GNU" >&6; } printf "%s\n" "#define HAS_GNU_GETAFFINITY_NP 1" >>confdefs.h -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include #include @@ -20748,14 +20167,12 @@ then : printf "%s\n" "BSD" >&6; } printf "%s\n" "#define HAS_BSD_GETAFFINITY_NP 1" >>confdefs.h -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: pthread_getaffinity_np not found" >&5 -printf "%s\n" "pthread_getaffinity_np not found" >&6; } ;; -esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: pthread_getaffinity_np not found" >&5 +printf "%s\n" "pthread_getaffinity_np not found" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ - conftest$ac_exeext conftest.$ac_ext ;; -esac + conftest$ac_exeext conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam \ conftest$ac_exeext conftest.$ac_ext @@ -20765,9 +20182,8 @@ rm -f core conftest.err conftest.$ac_objext conftest.beam \ if test x"$enable_runtime5" = x"yes" then : runtime_suffix= -else case e in #( - e) runtime_suffix=4 ;; -esac +else $as_nop + runtime_suffix=4 fi case $enable_systhreads,$enable_unix_lib in #( @@ -20837,11 +20253,10 @@ then : as_has_debug_prefix_map=true { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } -else case e in #( - e) ashas_debug_prefix_map=false +else $as_nop + ashas_debug_prefix_map=false { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } ;; -esac +printf "%s\n" "no" >&6; } fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext @@ -20864,8 +20279,8 @@ printf %s "checking whether the assembler supports CFI directives... " >&6; } then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: disabled" >&5 printf "%s\n" "disabled" >&6; } -else case e in #( - e) +else $as_nop + saved_CC="$CC" saved_CFLAGS="$CFLAGS" saved_CPPFLAGS="$CPPFLAGS" @@ -20899,17 +20314,16 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : aspp_ok=true -else case e in #( - e) aspp_ok=false ;; -esac +else $as_nop + aspp_ok=false fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext if test "$AS" = "$ASPP" then : as_ok="$aspp_ok" -else case e in #( - e) CC="$AS" +else $as_nop + CC="$AS" ac_compile='$CC $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ @@ -20925,12 +20339,10 @@ _ACEOF if ac_fn_c_try_compile "$LINENO" then : as_ok=true -else case e in #( - e) as_ok=false ;; -esac +else $as_nop + as_ok=false fi -rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ;; -esac +rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi @@ -20951,23 +20363,20 @@ then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } -else case e in #( - e) if test x"$enable_cfi" = "xyes" +else $as_nop + if test x"$enable_cfi" = "xyes" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: requested but not available as_fn_error $? "exiting" "$LINENO" 5" >&5 printf "%s\n" "requested but not available as_fn_error $? "exiting" "$LINENO" 5" >&6; } -else case e in #( - e) asm_cfi_supported=false +else $as_nop + asm_cfi_supported=false { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } ;; -esac -fi ;; -esac +printf "%s\n" "no" >&6; } fi - ;; -esac +fi + fi ;; esac fi @@ -20988,11 +20397,10 @@ printf "%s\n" "$as_me: using frame pointers" >&6;} ;; #( as_fn_error $? "frame pointers not supported on this platform" "$LINENO" 5 ;; esac -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: not using frame pointers" >&5 +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: not using frame pointers" >&5 printf "%s\n" "$as_me: not using frame pointers" >&6;} - frame_pointers=false ;; -esac + frame_pointers=false fi ## CPP mangling @@ -21002,9 +20410,8 @@ then : cpp_mangling=true printf "%s\n" "#define WITH_CPP_MANGLING 1" >>confdefs.h -else case e in #( - e) cpp_mangling=false ;; -esac +else $as_nop + cpp_mangling=false fi ## No naked pointers @@ -21014,9 +20421,8 @@ then : naked_pointers=false printf "%s\n" "#define NO_NAKED_POINTERS 1" >>confdefs.h -else case e in #( - e) naked_pointers=true ;; -esac +else $as_nop + naked_pointers=true fi if test x"$enable_naked_pointers_checker" = "xyes" @@ -21039,9 +20445,8 @@ fi *) : ;; esac -else case e in #( - e) naked_pointers_checker=false ;; -esac +else $as_nop + naked_pointers_checker=false fi ## Check for mmap support for huge pages and contiguous heap @@ -21052,8 +20457,8 @@ printf %s "checking whether mmap supports huge pages... " >&6; } then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no assumed" >&5 printf "%s\n" "no assumed" >&6; } -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include @@ -21102,14 +20507,12 @@ then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } ;; -esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext ;; -esac + conftest.$ac_objext conftest.beam conftest.$ac_ext fi @@ -21140,25 +20543,22 @@ printf "%s\n" "#define CUSTOM_OPS_STRUCT_SIZE $custom_ops_struct_size" >>confdef if test x"$enable_installing_bytecode_programs" = "xno" then : install_bytecode_programs=false -else case e in #( - e) install_bytecode_programs=true ;; -esac +else $as_nop + install_bytecode_programs=true fi if test x"$enable_installing_source_artifacts" = "xno" then : install_source_artifacts=false -else case e in #( - e) install_source_artifacts=true ;; -esac +else $as_nop + install_source_artifacts=true fi if test x"$enable_stdlib_manpages" != "xno" then : build_libraries_manpages=true -else case e in #( - e) build_libraries_manpages=false ;; -esac +else $as_nop + build_libraries_manpages=false fi documentation_tool_cmd='' @@ -21175,9 +20575,8 @@ then : documentation_tool_cmd="$withval" documentation_tool='odoc' ;; esac -else case e in #( - e) documentation_tool='ocamldoc' ;; -esac +else $as_nop + documentation_tool='ocamldoc' fi if test "x$documentation_tool_cmd" = 'x' @@ -21216,8 +20615,8 @@ printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_DIFF+y} then : printf %s "(cached) " >&6 -else case e in #( - e) if test -n "$DIFF"; then +else $as_nop + if test -n "$DIFF"; then ac_cv_prog_DIFF="$DIFF" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR @@ -21239,8 +20638,7 @@ done done IFS=$as_save_IFS -fi ;; -esac +fi fi DIFF=$ac_cv_prog_DIFF if test -n "$DIFF"; then @@ -21274,78 +20672,37 @@ then : DIFF_FLAGS="$DIFF_FLAGS $flag" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } ;; -esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } fi done fi -if test x"$enable_flambda" = "xyes" -then : - flambda=true - flambda2=false - if test x"$enable_flambda2" = "xyes" -then : - as_fn_error $? "please enable only one of Flambda 1 and Flambda 2" "$LINENO" 5 -fi -else case e in #( - e) flambda=false ;; -esac -fi - -if test x"$enable_flambda2" = "xyes" -then : - flambda2=true - flambda=false -else case e in #( - e) flambda2=false ;; -esac -fi +flambda=false +flambda2=true if test x"$enable_flambda_invariants" = "xyes" then : flambda_invariants=true -else case e in #( - e) flambda_invariants=false ;; -esac -fi - -if test x"$enable_cmm_invariants" = "xyes" -then : - cmm_invariants=true -else case e in #( - e) cmm_invariants=false ;; -esac -fi - -if $flambda -then : - CMX_MAGIC_NUMBER=Caml1999y550 - CMXA_MAGIC_NUMBER=Caml1999z550 -else case e in #( - e) CMX_MAGIC_NUMBER=Caml1999Y550 - CMXA_MAGIC_NUMBER=Caml1999Z550 ;; -esac +else $as_nop + flambda_invariants=false fi if test x"$enable_cmm_invariants" = "xyes" then : cmm_invariants=true -else case e in #( - e) cmm_invariants=false ;; -esac +else $as_nop + cmm_invariants=false fi if test x"$enable_flat_float_array" = "xno" then : flat_float_array=false -else case e in #( - e) printf "%s\n" "#define FLAT_FLOAT_ARRAY 1" >>confdefs.h +else $as_nop + printf "%s\n" "#define FLAT_FLOAT_ARRAY 1" >>confdefs.h - flat_float_array=true ;; -esac + flat_float_array=true fi @@ -21355,8 +20712,8 @@ printf %s "checking whether mmap supports MAP_STACK... " >&6; } then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no assumed" >&5 printf "%s\n" "no assumed" >&6; } -else case e in #( - e) cat confdefs.h - <<_ACEOF >conftest.$ac_ext +else $as_nop + cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include @@ -21379,14 +20736,12 @@ then : has_mmap_map_stack=true { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 -printf "%s\n" "no" >&6; } ;; -esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } fi rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ - conftest.$ac_objext conftest.beam conftest.$ac_ext ;; -esac + conftest.$ac_objext conftest.beam conftest.$ac_ext fi @@ -21402,13 +20757,12 @@ then : printf "%s\n" "#define USE_MMAP_MAP_STACK 1" >>confdefs.h ;; esac -else case e in #( - e) as_fn_error $? "mmap MAP_STACK requested but not found on $target" "$LINENO" 5 ;; -esac +else $as_nop + as_fn_error $? "mmap MAP_STACK requested but not found on $target" "$LINENO" 5 fi -else case e in #( - e) case $target in #( +else $as_nop + case $target in #( *-openbsd*) : with_mmap_map_stack=true; printf "%s\n" "#define USE_MMAP_MAP_STACK 1" >>confdefs.h @@ -21418,8 +20772,7 @@ printf "%s\n" "$as_me: using MAP_STACK on OpenBSD due to stack checking" >&6;} ; *) : with_mmap_map_stack=false ;; esac - ;; -esac + fi oc_native_compflags='' @@ -21427,8 +20780,8 @@ oc_native_compflags='' if test x"$enable_function_sections" = "xno" then : function_sections=false -else case e in #( - e) case $arch in #( +else $as_nop + case $arch in #( amd64|arm64) : # not supported on arm32, see issue #9124. case $target in #( @@ -21472,13 +20825,11 @@ then : if test x"$enable_function_sections" = "xyes" then : as_fn_error $? "Function sections are not supported." "$LINENO" 5 -else case e in #( - e) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Disabling function sections." >&5 -printf "%s\n" "$as_me: Disabling function sections." >&6;} ;; -esac +else $as_nop + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: Disabling function sections." >&5 +printf "%s\n" "$as_me: Disabling function sections." >&6;} +fi fi -fi ;; -esac fi case $arch in #( @@ -21506,9 +20857,8 @@ fi if test x"$with_afl" = "xyes" then : afl=true -else case e in #( - e) afl=false ;; -esac +else $as_nop + afl=false fi # Enable debugging support @@ -21522,18 +20872,16 @@ fi if test x"$enable_stack_allocation" = "xno" then : stack_allocation=false -else case e in #( - e) if $arch64 +else $as_nop + if $arch64 then : printf "%s\n" "#define STACK_ALLOCATION 1" >>confdefs.h stack_allocation=true -else case e in #( - e) as_fn_error $? "Stack allocation is only supported on 64-bit platforms. \ -Please pass '--enable-stack-allocation=no'." "$LINENO" 5 ;; -esac -fi ;; -esac +else $as_nop + as_fn_error $? "Stack allocation is only supported on 64-bit platforms. \ +Please pass '--enable-stack-allocation=no'." "$LINENO" 5 +fi fi if test x"$enable_poll_insertion" = "xyes" @@ -21541,9 +20889,8 @@ then : printf "%s\n" "#define POLL_INSERTION 1" >>confdefs.h poll_insertion=true -else case e in #( - e) poll_insertion=false ;; -esac +else $as_nop + poll_insertion=false fi oc_cflags="$common_cflags $internal_cflags" @@ -21609,8 +20956,8 @@ then : *) : ;; esac -else case e in #( - e) if test x"$unix_or_win32" = "xwin32" \ +else $as_nop + if test x"$unix_or_win32" = "xwin32" \ && test "$host_vendor-$host_os" != "$build_vendor-$build_os" then : case $build in #( @@ -21619,8 +20966,7 @@ then : *) : ;; esac -fi ;; -esac +fi fi # Define a few macros that were defined in config/m-nt.h @@ -21682,8 +21028,8 @@ cat >confcache <<\_ACEOF # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # -# 'ac_cv_env_foo' variables (set or unset) will be overridden when -# loading this file, other *unset* 'ac_cv_foo' will be assigned the +# `ac_cv_env_foo' variables (set or unset) will be overridden when +# loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF @@ -21713,14 +21059,14 @@ printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) - # 'set' does not quote correctly, so add quotes: double-quote + # `set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) - # 'set' quotes correctly as required by POSIX, so do not add quotes. + # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | @@ -21882,8 +21228,8 @@ fi mkdll_ldflags="\$(addprefix ${mkexe_ldflags_prefix},\$(OC_DLL_LDFLAGS)) \ ${mkdll_ldflags}" -else case e in #( - e) +else $as_nop + mkdll_ldflags='$(OC_DLL_LDFLAGS) $(LDFLAGS)' mkdll_ldflags_exp="${oc_dll_ldflags}" if test -n ${LDFLAGS} @@ -21892,8 +21238,7 @@ then : fi mkexe_ldflags="\$(OC_LDFLAGS) \$(LDFLAGS)" mkexe_ldflags_exp="${oc_ldflags} ${LDFLAGS}" - ;; -esac + fi mkexe="$mkexe $mkexe_ldflags" mkexe_exp="$mkexe_exp $mkexe_ldflags_exp" @@ -21909,21 +21254,19 @@ then : mkexe_via_cc_ldflags=\ "\$(addprefix ${mkexe_via_cc_ldflags_prefix},\$(OC_LDFLAGS) \$(LDFLAGS))" -else case e in #( - e) +else $as_nop + mkexe_via_cc_ldflags='$(OC_LDFLAGS) $(LDFLAGS)' - ;; -esac + fi # cl requires linker flags after the objects. if test "$ccomptype" = 'msvc' then : mkexe_via_cc_ldflags=\ "\$(OUTPUTEXE)\$(1) \$(2) $mkexe_via_cc_ldflags" -else case e in #( - e) mkexe_via_cc_ldflags=\ -"$mkexe_via_cc_ldflags \$(OUTPUTEXE)\$(1) \$(2)" ;; -esac +else $as_nop + mkexe_via_cc_ldflags=\ +"$mkexe_via_cc_ldflags \$(OUTPUTEXE)\$(1) \$(2)" fi if test -n "$mkexe_via_cc_extra_cmd" then : @@ -21959,6 +21302,7 @@ cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh +as_nop=: if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh @@ -21967,13 +21311,12 @@ then : # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST -else case e in #( - e) case `(set -o) 2>/dev/null` in #( +else $as_nop + case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; -esac ;; esac fi @@ -22045,7 +21388,7 @@ IFS=$as_save_IFS ;; esac -# We did not find ourselves, most probably we were run as 'sh COMMAND' +# We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 @@ -22074,6 +21417,7 @@ as_fn_error () } # as_fn_error + # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. @@ -22113,12 +21457,11 @@ then : { eval $1+=\$2 }' -else case e in #( - e) as_fn_append () +else $as_nop + as_fn_append () { eval $1=\$$1\$2 - } ;; -esac + } fi # as_fn_append # as_fn_arith ARG... @@ -22132,12 +21475,11 @@ then : { as_val=$(( $* )) }' -else case e in #( - e) as_fn_arith () +else $as_nop + as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` - } ;; -esac + } fi # as_fn_arith @@ -22220,9 +21562,9 @@ if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: - # 1) On MSYS, both 'ln -s file dir' and 'ln file dir' fail. - # 2) DJGPP < 2.04 has no symlinks; 'ln -s' creates a wrapper executable. - # In both cases, we have to default to 'cp -pR'. + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then @@ -22303,12 +21645,10 @@ as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. -as_sed_cpp="y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g" -as_tr_cpp="eval sed '$as_sed_cpp'" # deprecated +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. -as_sed_sh="y%*+%pp%;s%[^_$as_cr_alnum]%_%g" -as_tr_sh="eval sed '$as_sed_sh'" # deprecated +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 @@ -22324,7 +21664,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # values after options handling. ac_log=" This file was extended by OCaml $as_me 5.2.0+jst, which was -generated by GNU Autoconf 2.72. Invocation command line was +generated by GNU Autoconf 2.71. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS @@ -22357,7 +21697,7 @@ _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ -'$as_me' instantiates files and other configuration actions +\`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. @@ -22397,10 +21737,10 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ OCaml config.status 5.2.0+jst -configured by $0, generated by GNU Autoconf 2.72, +configured by $0, generated by GNU Autoconf 2.71, with options \\"\$ac_cs_config\\" -Copyright (C) 2023 Free Software Foundation, Inc. +Copyright (C) 2021 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." @@ -22461,8 +21801,8 @@ do ac_need_defaults=false;; --he | --h) # Conflict between --help and --header - as_fn_error $? "ambiguous option: '$1' -Try '$0 --help' for more information.";; + as_fn_error $? "ambiguous option: \`$1' +Try \`$0 --help' for more information.";; --help | --hel | -h ) printf "%s\n" "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ @@ -22470,8 +21810,8 @@ Try '$0 --help' for more information.";; ac_cs_silent=: ;; # This is an error. - -*) as_fn_error $? "unrecognized option: '$1' -Try '$0 --help' for more information." ;; + -*) as_fn_error $? "unrecognized option: \`$1' +Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; @@ -22845,7 +22185,7 @@ do "otherlibs/systhreads4/META") CONFIG_FILES="$CONFIG_FILES otherlibs/systhreads4/META" ;; "ocamltest/ocamltest_unix.ml") CONFIG_LINKS="$CONFIG_LINKS ocamltest/ocamltest_unix.ml:${ocamltest_unix_mod}" ;; - *) as_fn_error $? "invalid argument: '$ac_config_target'" "$LINENO" 5;; + *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done @@ -22866,7 +22206,7 @@ fi # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: -# after its creation but before its name has been assigned to '$tmp'. +# after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= ac_tmp= @@ -22890,7 +22230,7 @@ ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. -# This happens for instance with './config.status config.h'. +# This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then @@ -23048,13 +22388,13 @@ fi # test -n "$CONFIG_FILES" # Set up the scripts for CONFIG_HEADERS section. # No need to generate them if there are no CONFIG_HEADERS. -# This happens for instance with './config.status Makefile'. +# This happens for instance with `./config.status Makefile'. if test -n "$CONFIG_HEADERS"; then cat >"$ac_tmp/defines.awk" <<\_ACAWK || BEGIN { _ACEOF -# Transform confdefs.h into an awk script 'defines.awk', embedded as +# Transform confdefs.h into an awk script `defines.awk', embedded as # here-document in config.status, that substitutes the proper values into # config.h.in to produce config.h. @@ -23164,7 +22504,7 @@ do esac case $ac_mode$ac_tag in :[FHL]*:*);; - :L* | :C*:*) as_fn_error $? "invalid tag '$ac_tag'" "$LINENO" 5;; + :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac @@ -23186,19 +22526,19 @@ do -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, - # because $ac_f cannot contain ':'. + # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || - as_fn_error 1 "cannot find input file: '$ac_f'" "$LINENO" 5;; + as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`printf "%s\n" "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done - # Let's still pretend it is 'configure' which instantiates (i.e., don't + # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` @@ -23326,7 +22666,7 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 esac _ACEOF -# Neutralize VPATH when '$srcdir' = '.'. +# Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 @@ -23356,9 +22696,9 @@ test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && - { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable 'datarootdir' + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 -printf "%s\n" "$as_me: WARNING: $ac_file contains a reference to the variable 'datarootdir' +printf "%s\n" "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" diff --git a/ocaml/configure.ac b/ocaml/configure.ac index dc21b7ae2cc..0e6f7abe187 100644 --- a/ocaml/configure.ac +++ b/ocaml/configure.ac @@ -134,8 +134,8 @@ AC_SUBST([EXEC_MAGIC_NUMBER], [EXEC__MAGIC_NUMBER]) AC_SUBST([CMI_MAGIC_NUMBER], [CMI__MAGIC_NUMBER]) AC_SUBST([CMO_MAGIC_NUMBER], [CMO__MAGIC_NUMBER]) AC_SUBST([CMA_MAGIC_NUMBER], [CMA__MAGIC_NUMBER]) -AC_SUBST([CMX_MAGIC_NUMBER]) -AC_SUBST([CMXA_MAGIC_NUMBER]) +AC_SUBST([CMX_MAGIC_NUMBER], [CMX__MAGIC_NUMBER]) +AC_SUBST([CMXA_MAGIC_NUMBER], [CMXA__MAGIC_NUMBER]) AC_SUBST([AST_IMPL_MAGIC_NUMBER], [AST_IMPL__MAGIC_NUMBER]) AC_SUBST([AST_INTF_MAGIC_NUMBER], [AST_INTF__MAGIC_NUMBER]) AC_SUBST([CMXS_MAGIC_NUMBER], [CMXS__MAGIC_NUMBER]) @@ -2647,18 +2647,8 @@ AS_IF([$build_ocamltest], [AC_MSG_RESULT([no])]) done]) -AS_IF([test x"$enable_flambda" = "xyes"], - [flambda=true - flambda2=false - AS_IF([test x"$enable_flambda2" = "xyes"], - [AC_MSG_ERROR([please enable only one of Flambda 1 and Flambda 2])], - [])], - [flambda=false]) - -AS_IF([test x"$enable_flambda2" = "xyes"], - [flambda2=true - flambda=false], - [flambda2=false]) +flambda=false +flambda2=true AS_IF([test x"$enable_flambda_invariants" = "xyes"], [flambda_invariants=true], @@ -2668,16 +2658,6 @@ AS_IF([test x"$enable_cmm_invariants" = "xyes"], [cmm_invariants=true], [cmm_invariants=false]) -AS_IF([$flambda], - [CMX_MAGIC_NUMBER=CMX_FLAMBDA__MAGIC_NUMBER - CMXA_MAGIC_NUMBER=CMXA_FLAMBDA__MAGIC_NUMBER], - [CMX_MAGIC_NUMBER=CMX_CLAMBDA__MAGIC_NUMBER - CMXA_MAGIC_NUMBER=CMXA_CLAMBDA__MAGIC_NUMBER]) - -AS_IF([test x"$enable_cmm_invariants" = "xyes"], - [cmm_invariants=true], - [cmm_invariants=false]) - AS_IF([test x"$enable_flat_float_array" = "xno"], [flat_float_array=false], [AC_DEFINE([FLAT_FLOAT_ARRAY]) diff --git a/ocaml/testsuite/tests/typing-layouts-products/basics_alpha.ml b/ocaml/testsuite/tests/typing-layouts-products/basics_alpha.ml index 9b3612644d0..ec7b0f2194d 100644 --- a/ocaml/testsuite/tests/typing-layouts-products/basics_alpha.ml +++ b/ocaml/testsuite/tests/typing-layouts-products/basics_alpha.ml @@ -57,9 +57,9 @@ type t2 : any mod non_null Line 3, characters 0-39: 3 | type t3 : any mod non_null = #(t1 * t2);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The kind of type #(t1 * t2) is any & any +Error: The kind of type "#(t1 * t2)" is any & any because it is an unboxed tuple. - But the kind of type #(t1 * t2) must be a subkind of any_non_null + But the kind of type "#(t1 * t2)" must be a subkind of any_non_null because of the definition of t3 at line 3, characters 0-39. |}] @@ -72,9 +72,9 @@ type t2 : any mod non_null Line 3, characters 0-47: 3 | type t3 : (any & any) mod non_null = #(t1 * t2);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The kind of type #(t1 * t2) is any & any +Error: The kind of type "#(t1 * t2)" is any & any because it is an unboxed tuple. - But the kind of type #(t1 * t2) must be a subkind of + But the kind of type "#(t1 * t2)" must be a subkind of any_non_null & any_non_null because of the definition of t3 at line 3, characters 0-47. |}] @@ -88,9 +88,9 @@ type t2 : any mod non_null Line 3, characters 0-58: 3 | type t3 : any mod non_null & any mod non_null = #(t1 * t2);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The kind of type #(t1 * t2) is any & any +Error: The kind of type "#(t1 * t2)" is any & any because it is an unboxed tuple. - But the kind of type #(t1 * t2) must be a subkind of + But the kind of type "#(t1 * t2)" must be a subkind of any_non_null & any_non_null because of the definition of t3 at line 3, characters 0-58. |}] diff --git a/ocaml/utils/misc.ml b/ocaml/utils/misc.ml index 145a363918f..89ebf676323 100644 --- a/ocaml/utils/misc.ml +++ b/ocaml/utils/misc.ml @@ -1259,38 +1259,22 @@ module Bitmap = struct end module Magic_number = struct - type native_obj_config = { - flambda : bool; - } - let native_obj_config = { - (* This must match the logic in the configure script for deciding - which magic numbers to use. *) - flambda = Config.flambda; - } - type version = int type kind = | Exec | Cmi | Cmo | Cma - | Cmx of native_obj_config | Cmxa of native_obj_config + | Cmx | Cmxa | Cmxs | Cmt | Cms | Ast_impl | Ast_intf (* please keep up-to-date, this is used for sanity checking *) - let all_native_obj_configs = [ - {flambda = true}; - {flambda = false}; - ] let all_kinds = [ Exec; Cmi; Cmo; Cma; - ] - @ List.map (fun conf -> Cmx conf) all_native_obj_configs - @ List.map (fun conf -> Cmxa conf) all_native_obj_configs - @ [ + Cmx; Cmxa; Cmt; Ast_impl; Ast_intf; ] @@ -1308,10 +1292,8 @@ module Magic_number = struct | "Caml1999I" -> Some Cmi | "Caml1999O" -> Some Cmo | "Caml1999A" -> Some Cma - | "Caml2021y" -> Some (Cmx {flambda = true}) - | "Caml2021Y" -> Some (Cmx {flambda = false}) - | "Caml2021z" -> Some (Cmxa {flambda = true}) - | "Caml2021Z" -> Some (Cmxa {flambda = false}) + | "Caml2021Y" -> Some Cmx + | "Caml2021Z" -> Some Cmxa (* Caml2007D and Caml2012T were used instead of the common Caml1999 prefix between the introduction of those magic numbers and October 2017 @@ -1335,14 +1317,8 @@ module Magic_number = struct | Cmi -> "Caml1999I" | Cmo -> "Caml1999O" | Cma -> "Caml1999A" - | Cmx config -> - if config.flambda - then "Caml2021y" - else "Caml2021Y" - | Cmxa config -> - if config.flambda - then "Caml2021z" - else "Caml2021Z" + | Cmx -> "Caml2021Y" + | Cmxa -> "Caml2021Z" | Cmxs -> "Caml1999D" | Cmt -> "Caml1999T" | Cms -> "Caml1999S" @@ -1354,29 +1330,21 @@ module Magic_number = struct | Cmi -> "cmi" | Cmo -> "cmo" | Cma -> "cma" - | Cmx _ -> "cmx" - | Cmxa _ -> "cmxa" + | Cmx -> "cmx" + | Cmxa -> "cmxa" | Cmxs -> "cmxs" | Cmt -> "cmt" | Cms -> "cms" | Ast_impl -> "ast_impl" | Ast_intf -> "ast_intf" - let human_description_of_native_obj_config : native_obj_config -> string = - fun[@warning "+9"] {flambda} -> - if flambda then "flambda" else "non flambda" - let human_name_of_kind : kind -> string = function | Exec -> "executable" | Cmi -> "compiled interface file" | Cmo -> "bytecode object file" | Cma -> "bytecode library" - | Cmx config -> - Printf.sprintf "native compilation unit description (%s)" - (human_description_of_native_obj_config config) - | Cmxa config -> - Printf.sprintf "static native library (%s)" - (human_description_of_native_obj_config config) + | Cmx -> "native compilation unit description" + | Cmxa -> "static native library (%s)" | Cmxs -> "dynamic native library" | Cmt -> "compiled typedtree file" | Cms -> "compiled shape file" @@ -1443,26 +1411,8 @@ module Magic_number = struct | Cmi -> cmi_magic_number | Cmo -> cmo_magic_number | Cma -> cma_magic_number - | Cmx config -> - (* the 'if' guarantees that in the common case - we return the "trusted" value from Config. *) - let reference = cmx_magic_number in - if config = native_obj_config then reference - else - (* otherwise we stitch together the magic number - for a different configuration by concatenating - the right magic kind at this configuration - and the rest of the current raw number for our configuration. *) - let raw_kind = raw_kind kind in - let len = String.length raw_kind in - raw_kind ^ String.sub reference len (String.length reference - len) - | Cmxa config -> - let reference = cmxa_magic_number in - if config = native_obj_config then reference - else - let raw_kind = raw_kind kind in - let len = String.length raw_kind in - raw_kind ^ String.sub reference len (String.length reference - len) + | Cmx -> cmx_magic_number + | Cmxa -> cmxa_magic_number | Cmxs -> cmxs_magic_number | Cmt -> cmt_magic_number | Cms -> cms_magic_number diff --git a/ocaml/utils/misc.mli b/ocaml/utils/misc.mli index fb2fcd408ce..e3cdf292e1c 100644 --- a/ocaml/utils/misc.mli +++ b/ocaml/utils/misc.mli @@ -776,23 +776,12 @@ module Magic_number : sig @since 4.11 *) - type native_obj_config = { - flambda : bool; - } - (** native object files have a format and magic number that depend - on certain native-compiler configuration parameters. This - configuration space is expressed by the [native_obj_config] - type. *) - - val native_obj_config : native_obj_config - (** the native object file configuration of the active/configured compiler. *) - type version = int type kind = | Exec | Cmi | Cmo | Cma - | Cmx of native_obj_config | Cmxa of native_obj_config + | Cmx | Cmxa | Cmxs | Cmt | Cms | Ast_impl | Ast_intf diff --git a/tools/flambda_backend_objinfo.ml b/tools/flambda_backend_objinfo.ml index c98bb82e111..e8d7ef586ec 100644 --- a/tools/flambda_backend_objinfo.ml +++ b/tools/flambda_backend_objinfo.ml @@ -423,7 +423,7 @@ let dump_obj_by_kind filename ic obj_kind = close_in ic; let cms = Cms_format.read filename in print_cms_infos cms - | Cmx _config -> + | Cmx -> let uir = (input_value ic : unit_infos_raw) in let first_section_offset = pos_in ic in seek_in ic (first_section_offset + uir.uir_sections_length); @@ -432,7 +432,7 @@ let dump_obj_by_kind filename ic obj_kind = let sections = Flambda_backend_utils.File_sections.create uir.uir_section_toc filename ic ~first_section_offset in print_cmx_infos (uir, sections, crc) - | Cmxa _config -> + | Cmxa -> let li = (input_value ic : library_infos) in close_in ic; print_cmxa_infos li From fccdd707ccd68c7e1ad67d552a08c4dced734308 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 9 Sep 2024 17:51:28 +0100 Subject: [PATCH 30/76] Trying to fix magic number tests --- ocaml/testsuite/tests/utils/magic_number.ml | 11 ++++++++++- ocaml/utils/misc.ml | 8 ++++---- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/ocaml/testsuite/tests/utils/magic_number.ml b/ocaml/testsuite/tests/utils/magic_number.ml index 42664ec80b5..9744d6bc38a 100644 --- a/ocaml/testsuite/tests/utils/magic_number.ml +++ b/ocaml/testsuite/tests/utils/magic_number.ml @@ -10,9 +10,18 @@ open Magic_number (* sanity checking: the magic number at a given kind can be parsed back *) let error kind test = fatal_errorf - "Internal compiler error (%s): there is a magic number mismatch on kind %s" + "Internal compiler error (%s): there is a magic number mismatch on kind %s, raw_kind %s ==> %s" test (string_of_kind kind) + (raw_kind kind) + (match parse (current_raw kind) with + | Error (Truncated s) -> "A: " ^ s + | Error (Not_a_magic_number s) -> "AM: " ^ s + | Ok magic -> + if not ( magic.kind = kind) then "B" + else if not (raw magic = current_raw kind) then "C" + else "D") + let check_raw_kind kind = let valid = diff --git a/ocaml/utils/misc.ml b/ocaml/utils/misc.ml index 89ebf676323..bc4c23b3211 100644 --- a/ocaml/utils/misc.ml +++ b/ocaml/utils/misc.ml @@ -1292,8 +1292,8 @@ module Magic_number = struct | "Caml1999I" -> Some Cmi | "Caml1999O" -> Some Cmo | "Caml1999A" -> Some Cma - | "Caml2021Y" -> Some Cmx - | "Caml2021Z" -> Some Cmxa + | "Caml1999Y" -> Some Cmx + | "Caml1999Z" -> Some Cmxa (* Caml2007D and Caml2012T were used instead of the common Caml1999 prefix between the introduction of those magic numbers and October 2017 @@ -1317,8 +1317,8 @@ module Magic_number = struct | Cmi -> "Caml1999I" | Cmo -> "Caml1999O" | Cma -> "Caml1999A" - | Cmx -> "Caml2021Y" - | Cmxa -> "Caml2021Z" + | Cmx -> "Caml1999Y" + | Cmxa -> "Caml1999Z" | Cmxs -> "Caml1999D" | Cmt -> "Caml1999T" | Cms -> "Caml1999S" From 7ab015935a68ca731d2fdbd1005ba3663aca2061 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 9 Sep 2024 17:55:51 +0100 Subject: [PATCH 31/76] Trying to fix magic number tests --- ocaml/aclocal.m4 | 1 - 1 file changed, 1 deletion(-) diff --git a/ocaml/aclocal.m4 b/ocaml/aclocal.m4 index aa8556ea3b2..cb73385dda2 100644 --- a/ocaml/aclocal.m4 +++ b/ocaml/aclocal.m4 @@ -31,7 +31,6 @@ m4_include([build-aux/ax_check_compile_flag.m4]) # Macros from the autoconf macro archive m4_include([build-aux/ax_func_which_gethostbyname_r.m4]) m4_include([build-aux/ax_pthread.m4]) -m4_include([build-aux/ax_check_compile_flag.m4]) # OCaml version m4_include([build-aux/ocaml_version.m4]) From 52f5c0d3d6a771d62e89d74155cb3a7ca2aa34bb Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 9 Sep 2024 18:01:26 +0100 Subject: [PATCH 32/76] git checkout 1b8905 -- ocaml/testsuite/tests/utils/magic_number.ml --- ocaml/testsuite/tests/utils/magic_number.ml | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/ocaml/testsuite/tests/utils/magic_number.ml b/ocaml/testsuite/tests/utils/magic_number.ml index 9744d6bc38a..42664ec80b5 100644 --- a/ocaml/testsuite/tests/utils/magic_number.ml +++ b/ocaml/testsuite/tests/utils/magic_number.ml @@ -10,18 +10,9 @@ open Magic_number (* sanity checking: the magic number at a given kind can be parsed back *) let error kind test = fatal_errorf - "Internal compiler error (%s): there is a magic number mismatch on kind %s, raw_kind %s ==> %s" + "Internal compiler error (%s): there is a magic number mismatch on kind %s" test (string_of_kind kind) - (raw_kind kind) - (match parse (current_raw kind) with - | Error (Truncated s) -> "A: " ^ s - | Error (Not_a_magic_number s) -> "AM: " ^ s - | Ok magic -> - if not ( magic.kind = kind) then "B" - else if not (raw magic = current_raw kind) then "C" - else "D") - let check_raw_kind kind = let valid = From e4d2e5ae7c095f7200fca4f1104fde358b31c635 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 9 Sep 2024 18:08:27 +0100 Subject: [PATCH 33/76] Promote backtrace tests --- .../tests/backtrace/backtrace_or_exception.opt.reference | 2 +- ocaml/testsuite/tests/backtrace/names.reference | 2 +- .../tests/backtrace/names_partial_application.byte.reference | 2 +- .../tests/backtrace/names_partial_application.opt.reference | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/ocaml/testsuite/tests/backtrace/backtrace_or_exception.opt.reference b/ocaml/testsuite/tests/backtrace/backtrace_or_exception.opt.reference index 7de21a13855..098f728fff6 100644 --- a/ocaml/testsuite/tests/backtrace/backtrace_or_exception.opt.reference +++ b/ocaml/testsuite/tests/backtrace/backtrace_or_exception.opt.reference @@ -6,7 +6,7 @@ exception Backtrace_or_exception.Exn Raised at Backtrace_or_exception.without_reraise in file "backtrace_or_exception.ml", line 23, characters 4-13 Called from Backtrace_or_exception.run in file "backtrace_or_exception.ml", line 43, characters 6-10 Re-raised at Backtrace_or_exception.return_exn in file "backtrace_or_exception.ml", line 14, characters 4-13 -Called from Backtrace_or_exception.return_exn in file "backtrace_or_exception.ml" (inlined), lines 12-16, characters 15-7 +Called from Backtrace_or_exception.return_exn in file "backtrace_or_exception.ml" (inlined), lines 12-16, characters 15-101 Called from Backtrace_or_exception.with_reraise in file "backtrace_or_exception.ml", line 27, characters 8-44 Re-raised at Backtrace_or_exception.with_reraise in file "backtrace_or_exception.ml", line 30, characters 4-13 Called from Backtrace_or_exception.run in file "backtrace_or_exception.ml", line 43, characters 6-10 diff --git a/ocaml/testsuite/tests/backtrace/names.reference b/ocaml/testsuite/tests/backtrace/names.reference index 093c39e40da..ae7f84cce48 100644 --- a/ocaml/testsuite/tests/backtrace/names.reference +++ b/ocaml/testsuite/tests/backtrace/names.reference @@ -29,4 +29,4 @@ Called from Names.Mod1.Nested.apply in file "names.ml", line 20, characters 33-3 Called from Names.fn_poly in file "names.ml", line 16, characters 2-5 Called from Names.fn_function in file "names.ml", line 13, characters 9-13 Called from Names.fn_multi in file "names.ml", line 10, characters 36-40 -Called from Names in file "names.ml", lines 117-137, characters 4-11 +Called from Names in file "names.ml", lines 117-137, characters 4-543 diff --git a/ocaml/testsuite/tests/backtrace/names_partial_application.byte.reference b/ocaml/testsuite/tests/backtrace/names_partial_application.byte.reference index c622216f93a..6106a969bac 100644 --- a/ocaml/testsuite/tests/backtrace/names_partial_application.byte.reference +++ b/ocaml/testsuite/tests/backtrace/names_partial_application.byte.reference @@ -1,4 +1,4 @@ Raised at Names_partial_application.bang in file "names_partial_application.ml", line 9, characters 29-39 Called from Names_partial_application.labelled_arguments_partial.f in file "names_partial_application.ml", line 12, characters 38-42 Called from Names_partial_application.labelled_arguments_partial in file "names_partial_application.ml", line 14, characters 2-15 -Called from Names_partial_application in file "names_partial_application.ml", lines 20-21, characters 4-11 +Called from Names_partial_application in file "names_partial_application.ml", lines 20-21, characters 4-54 diff --git a/ocaml/testsuite/tests/backtrace/names_partial_application.opt.reference b/ocaml/testsuite/tests/backtrace/names_partial_application.opt.reference index eba33411364..41d73f9c27d 100644 --- a/ocaml/testsuite/tests/backtrace/names_partial_application.opt.reference +++ b/ocaml/testsuite/tests/backtrace/names_partial_application.opt.reference @@ -2,4 +2,4 @@ Raised at Names_partial_application.bang in file "names_partial_application.ml", Called from Names_partial_application.labelled_arguments_partial.f in file "names_partial_application.ml", line 12, characters 38-42 Called from Names_partial_application.labelled_arguments_partial.(partial) in file "names_partial_application.ml", line 13, characters 37-45 Called from Names_partial_application.labelled_arguments_partial in file "names_partial_application.ml", line 14, characters 2-15 -Called from Names_partial_application in file "names_partial_application.ml", lines 20-21, characters 4-11 +Called from Names_partial_application in file "names_partial_application.ml", lines 20-21, characters 4-54 From bbdd4636940f11561023e16c906b009a51d16867 Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Tue, 10 Sep 2024 03:59:41 -0400 Subject: [PATCH 34/76] Fix bug in iarray accumulators, and add lots of tests (#3020) * Fix iarray mistakes around accumulator * Add local tests --- ocaml/otherlibs/stdlib_stable/iarray.ml | 8 +- .../testsuite/tests/lib-array/test_iarray.ml | 525 ++++++++++++++++++ 2 files changed, 529 insertions(+), 4 deletions(-) diff --git a/ocaml/otherlibs/stdlib_stable/iarray.ml b/ocaml/otherlibs/stdlib_stable/iarray.ml index c10a1680d68..080f2dda678 100644 --- a/ocaml/otherlibs/stdlib_stable/iarray.ml +++ b/ocaml/otherlibs/stdlib_stable/iarray.ml @@ -433,9 +433,9 @@ let fold_left_map_local f acc input_array = exclave_ let len = length input_array in if len = 0 then (acc, unsafe_of_local_array [||]) else begin let rec go acc i = exclave_ - let acc', elt = f acc (unsafe_get input_array i) in + let acc, elt = f acc (unsafe_get input_array i) in if i = len - 1 then - acc', make_mutable_local len elt + acc, make_mutable_local len elt else begin let (_, output_array) as res = go acc (i+1) in unsafe_set_local output_array i elt; @@ -464,9 +464,9 @@ let fold_left_map_local_output f acc input_array = exclave_ let len = length input_array in if len = 0 then (acc, unsafe_of_local_array [||]) else begin let rec go acc i = exclave_ - let acc', elt = f acc (unsafe_get input_array i) in + let acc, elt = f acc (unsafe_get input_array i) in if i = len - 1 then - acc', make_mutable_local len elt + acc, make_mutable_local len elt else begin let (_, output_array) as res = go acc (i+1) in unsafe_set_local output_array i elt; diff --git a/ocaml/testsuite/tests/lib-array/test_iarray.ml b/ocaml/testsuite/tests/lib-array/test_iarray.ml index 2d7fe8e9612..7d729a31238 100644 --- a/ocaml/testsuite/tests/lib-array/test_iarray.ml +++ b/ocaml/testsuite/tests/lib-array/test_iarray.ml @@ -10,18 +10,38 @@ external ( .:() ) : 'a iarray -> int -> 'a = "%array_safe_get";; (** Create some immutable and mutable arrays *) let iarray : int iarray = [:1;2;3;4;5:];; +let iarray_local () = exclave_ Iarray.init_local 5 (fun x -> x + 1);; let ifarray : float iarray = [:1.5;2.5;3.5;4.5;5.5:];; +let ifarray_local () = + exclave_ Iarray.init_local 5 (fun x -> Int.to_float x +. 1.5);; let marray : int array = [|1;2;3;4;5|];; let mfarray : float array = [|1.5;2.5;3.5;4.5;5.5|];; +external globalize_float : local_ float -> float = "%obj_dup";; +external globalize_string : local_ string -> string = "%obj_dup";; +let globalize_int_iarray (local_ ia) = + Iarray.map_local_input (fun x : int -> x) ia;; + +let rec list_map_local_input (local_ f) (local_ list) = + match list with + | [] -> [] + | x :: xs -> f x :: list_map_local_input f xs;; + [%%expect{| module Iarray = Stdlib_stable.Iarray external ( .:() ) : 'a iarray -> int -> 'a = "%array_safe_get" val iarray : int iarray = [:1; 2; 3; 4; 5:] +val iarray_local : unit -> local_ int iarray = val ifarray : float iarray = [:1.5; 2.5; 3.5; 4.5; 5.5:] +val ifarray_local : unit -> local_ float iarray = val marray : int array = [|1; 2; 3; 4; 5|] val mfarray : float array = [|1.5; 2.5; 3.5; 4.5; 5.5|] +external globalize_float : local_ float -> float = "%obj_dup" +external globalize_string : local_ string -> string = "%obj_dup" +val globalize_int_iarray : local_ int iarray -> int iarray = +val list_map_local_input : + local_ (local_ 'a -> 'b) -> local_ 'a list -> 'b list = |}];; (** Pattern-match on some immutable arrays, and check the typing of array @@ -169,11 +189,22 @@ Iarray.init 10 (fun x -> x * 2);; - : int iarray = [:0; 2; 4; 6; 8; 10; 12; 14; 16; 18:] |}];; +globalize_int_iarray (Iarray.init_local 10 (fun x -> x * 2));; +[%%expect{| +- : int iarray = [:0; 2; 4; 6; 8; 10; 12; 14; 16; 18:] +|}];; + Iarray.append iarray iarray;; [%%expect{| - : int iarray = [:1; 2; 3; 4; 5; 1; 2; 3; 4; 5:] |}];; +globalize_int_iarray (Iarray.append_local + (Iarray.init_local 5 (fun x -> x)) (iarray_local ()));; +[%%expect{| +- : int iarray = [:0; 1; 2; 3; 4; 1; 2; 3; 4; 5:] +|}];; + Iarray.concat [];; [%%expect{| - : 'a iarray = [::] @@ -186,6 +217,14 @@ Iarray.concat [ Iarray.init 1 (fun x -> 1 + x) - : int iarray = [:1; 20; 21; 300; 301; 302:] |}];; +globalize_int_iarray + (Iarray.concat_local [ Iarray.init_local 1 (fun x -> 1 + x) + ; Iarray.init_local 2 (fun x -> 20 + x) + ; Iarray.init_local 3 (fun x -> 300 + x) ]);; +[%%expect{| +- : int iarray = [:1; 20; 21; 300; 301; 302:] +|}];; + Iarray.sub iarray 0 2, Iarray.sub iarray 2 3;; [%%expect{| - : int iarray * int iarray = ([:1; 2:], [:3; 4; 5:]) @@ -206,16 +245,51 @@ Iarray.sub iarray 3 10;; Exception: Invalid_argument "Iarray.sub". |}];; +let iarray = iarray_local () in +globalize_int_iarray (Iarray.sub_local iarray 0 2), +globalize_int_iarray (Iarray.sub_local iarray 2 3);; +[%%expect{| +- : int iarray * int iarray = ([:1; 2:], [:3; 4; 5:]) +|}];; + +let iarray = iarray_local () in +globalize_int_iarray (Iarray.sub_local iarray (-1) 3);; +[%%expect{| +Exception: Invalid_argument "Iarray.sub". +|}];; + +let iarray = iarray_local () in +globalize_int_iarray (Iarray.sub_local iarray 1 (-3));; +[%%expect{| +Exception: Invalid_argument "Iarray.sub". +|}];; + +let iarray = iarray_local () in +globalize_int_iarray (Iarray.sub_local iarray 3 10);; +[%%expect{| +Exception: Invalid_argument "Iarray.sub". +|}];; + Iarray.to_list iarray;; [%%expect{| - : int list = [1; 2; 3; 4; 5] |}];; +list_map_local_input (fun x : int -> x) + (Iarray.to_list_local (iarray_local ()));; +[%%expect{| +- : int list = [1; 2; 3; 4; 5] +|}];; + Iarray.of_list [10;20;30];; [%%expect{| - : int iarray = [:10; 20; 30:] |}];; +globalize_int_iarray (Iarray.of_list_local [10;20;30]);; +[%%expect{| +- : int iarray = [:10; 20; 30:] +|}];; Iarray.to_array iarray;; [%%expect{| @@ -252,6 +326,19 @@ Iarray.iter (fun x -> sum := !sum +. x) ifarray; - : float = 17.5 |}];; +let open struct + external (+.) : + (float[@local_opt]) -> (float[@local_opt]) -> (float[@local_opt]) = + "%addfloat" +end in +let sum = ref 0. in +Iarray.iter_local (fun x -> sum := globalize_float (!sum +. x)) + [:1.5;2.5;3.5;4.5;5.5:]; +!sum;; +[%%expect{| +- : float = 17.5 +|}];; + let total = ref 0 in Iarray.iteri (fun i x -> total := !total + i*x) iarray; !total;; @@ -259,27 +346,121 @@ Iarray.iteri (fun i x -> total := !total + i*x) iarray; - : int = 40 |}];; +let total = ref 0 in +Iarray.iteri_local (fun i x -> total := !total + i*x) [:1;2;3;4;5:]; +!total;; +[%%expect{| +- : int = 40 +|}];; + Iarray.map Int.neg iarray;; [%%expect{| - : int iarray = [:-1; -2; -3; -4; -5:] |}];; +globalize_int_iarray (Iarray.map_local Int.neg + (iarray_local ()));; +[%%expect{| +- : int iarray = [:-1; -2; -3; -4; -5:] +|}];; + +Iarray.map_local_input Int.neg (iarray_local ());; +[%%expect{| +- : int iarray = [:-1; -2; -3; -4; -5:] +|}];; + +globalize_int_iarray (Iarray.map_local_output Int.neg iarray);; +[%%expect{| +- : int iarray = [:-1; -2; -3; -4; -5:] +|}];; + Iarray.mapi (fun i x -> i, 10.*.x) ifarray;; [%%expect{| - : (int * float) iarray = [:(0, 15.); (1, 25.); (2, 35.); (3, 45.); (4, 55.):] |}];; +let globalize_int_float_iarray (local_ ia) = + Iarray.map_local_input (fun ((i : int), f) -> i, globalize_float f) ia;; +[%%expect{| +val globalize_int_float_iarray : + local_ (int * float) iarray -> (int * float) iarray = +|}];; + +globalize_int_float_iarray + (Iarray.mapi_local (fun i x -> exclave_ i, 10.*.x) + (ifarray_local ()));; +[%%expect{| +- : (int * float) iarray = +[:(0, 15.); (1, 25.); (2, 35.); (3, 45.); (4, 55.):] +|}];; + +Iarray.mapi_local_input (fun i x -> i, 10. *. globalize_float x) + (ifarray_local ());; +[%%expect{| +- : (int * float) iarray = +[:(0, 15.); (1, 25.); (2, 35.); (3, 45.); (4, 55.):] +|}];; + +globalize_int_float_iarray + (Iarray.mapi_local_output (fun i x -> exclave_ i, 10.*.x) ifarray);; +[%%expect{| +- : (int * float) iarray = +[:(0, 15.); (1, 25.); (2, 35.); (3, 45.); (4, 55.):] +|}];; + Iarray.fold_left (fun acc x -> -x :: acc) [] iarray;; [%%expect{| - : int list = [-5; -4; -3; -2; -1] |}];; +list_map_local_input (fun x : int -> x) + (Iarray.fold_left_local (fun acc x -> exclave_ -x :: acc) [] + (iarray_local ()));; +[%%expect{| +- : int list = [-5; -4; -3; -2; -1] +|}];; + +Iarray.fold_left_local_input (fun acc x -> -x :: acc) [] + (iarray_local ());; +[%%expect{| +- : int list = [-5; -4; -3; -2; -1] +|}];; + +list_map_local_input (fun x : int -> x) + (Iarray.fold_left_local_output (fun acc x -> exclave_ -x :: acc) [] + iarray);; +[%%expect{| +- : int list = [-5; -4; -3; -2; -1] +|}];; + Iarray.fold_left_map (fun acc x -> acc + x, string_of_int x) 0 iarray;; [%%expect{| - : int * string iarray = (15, [:"1"; "2"; "3"; "4"; "5":]) |}];; +let n, strs = + Iarray.fold_left_map_local (fun acc x -> acc + x, string_of_int x) 0 iarray +in +n, Iarray.map_local_input globalize_string strs;; +[%%expect{| +- : int * string iarray = (15, [:"1"; "2"; "3"; "4"; "5":]) +|}];; + +Iarray.fold_left_map_local_input (fun acc x -> acc + x, string_of_int x) 0 iarray;; +[%%expect{| +- : int * string iarray = (15, [:"1"; "2"; "3"; "4"; "5":]) +|}];; + +let n, strs = + Iarray.fold_left_map_local_output + (fun acc x -> acc + x, string_of_int x) 0 iarray +in +n, Iarray.map_local_input globalize_string strs;; +[%%expect{| +- : int * string iarray = (15, [:"1"; "2"; "3"; "4"; "5":]) +|}];; + (* Confirm the function isn't called on the empty immutable array *) Iarray.fold_left_map (fun _ _ -> assert false) 0 [::];; [%%expect{| @@ -291,6 +472,26 @@ Iarray.fold_right (fun x acc -> -.x :: acc) ifarray [];; - : float list = [-1.5; -2.5; -3.5; -4.5; -5.5] |}];; +list_map_local_input globalize_float + (Iarray.fold_right_local (fun x acc -> exclave_ -.x :: acc) + (ifarray_local ()) []);; +[%%expect{| +- : float list = [-1.5; -2.5; -3.5; -4.5; -5.5] +|}];; + +Iarray.fold_right_local_input (fun x acc -> -. (globalize_float x) :: acc) + (ifarray_local ()) [];; +[%%expect{| +- : float list = [-1.5; -2.5; -3.5; -4.5; -5.5] +|}];; + +list_map_local_input globalize_float + (Iarray.fold_right_local_output (fun x acc -> exclave_ -.x :: acc) + ifarray []);; +[%%expect{| +- : float list = [-1.5; -2.5; -3.5; -4.5; -5.5] +|}];; + let ints = ref 0 in let floats = ref 0. in Iarray.iter2 @@ -304,12 +505,103 @@ Iarray.iter2 - : int * float = (15, 17.5) |}];; +let ints = ref 0 in +let floats = ref 0. in +Iarray.iter2_local + (fun i f -> + ints := i + !ints; + floats := globalize_float (f +. !floats)) + (iarray_local ()) (ifarray_local ()); +!ints, !floats;; +[%%expect{| +- : int * float = (15, 17.5) +|}];; + +let ints = ref 0 in +let floats = ref 0. in +Iarray.iter2_local_first + (fun i f -> + ints := i + !ints; + floats := f +. !floats) + (iarray_local ()) ifarray; +!ints, !floats;; +[%%expect{| +- : int * float = (15, 17.5) +|}];; + +let ints = ref 0 in +let floats = ref 0. in +Iarray.iter2_local_second + (fun i f -> + ints := i + !ints; + floats := globalize_float (f +. !floats)) + iarray (ifarray_local ()); +!ints, !floats;; +[%%expect{| +- : int * float = (15, 17.5) +|}];; + Iarray.map2 (fun i f -> f, i) iarray ifarray;; [%%expect{| - : (float * int) iarray = [:(1.5, 1); (2.5, 2); (3.5, 3); (4.5, 4); (5.5, 5):] |}];; +Iarray.map_local_input (fun (f, (i : int)) -> globalize_float f, i) + (Iarray.map2_local (fun i f -> exclave_ f, i) + (iarray_local ()) (ifarray_local ()));; +[%%expect{| +- : (float * int) iarray = +[:(1.5, 1); (2.5, 2); (3.5, 3); (4.5, 4); (5.5, 5):] +|}];; + +Iarray.map2_local_inputs (fun (i : int) f -> globalize_float f, i) + (iarray_local ()) (ifarray_local ());; +[%%expect{| +- : (float * int) iarray = +[:(1.5, 1); (2.5, 2); (3.5, 3); (4.5, 4); (5.5, 5):] +|}];; + +Iarray.map_local_input (fun (f, (i : int)) -> globalize_float f, i) + (Iarray.map2_local_output (fun i f -> exclave_ f, i) + iarray ifarray);; +[%%expect{| +- : (float * int) iarray = +[:(1.5, 1); (2.5, 2); (3.5, 3); (4.5, 4); (5.5, 5):] +|}];; + +Iarray.map2_local_first_input (fun (i : int) f -> f, i) + (iarray_local ()) ifarray;; +[%%expect{| +- : (float * int) iarray = +[:(1.5, 1); (2.5, 2); (3.5, 3); (4.5, 4); (5.5, 5):] +|}];; + +Iarray.map2_local_second_input (fun i f -> globalize_float f, i) + iarray (ifarray_local ());; +[%%expect{| +- : (float * int) iarray = +[:(1.5, 1); (2.5, 2); (3.5, 3); (4.5, 4); (5.5, 5):] +|}];; + +Iarray.map_local_input (fun (f, (i : int)) -> globalize_float f, i) + (Iarray.map2_local_first_input_and_output + (fun i f -> exclave_ f, i) + (iarray_local ()) ifarray);; +[%%expect{| +- : (float * int) iarray = +[:(1.5, 1); (2.5, 2); (3.5, 3); (4.5, 4); (5.5, 5):] +|}];; + +Iarray.map_local_input (fun (f, (i : int)) -> globalize_float f, i) + (Iarray.map2_local_second_input_and_output + (fun i f -> exclave_ f, i) + iarray (ifarray_local ()));; +[%%expect{| +- : (float * int) iarray = +[:(1.5, 1); (2.5, 2); (3.5, 3); (4.5, 4); (5.5, 5):] +|}];; + Iarray.for_all (fun i -> i > 0) iarray;; [%%expect{| - : bool = true @@ -320,6 +612,16 @@ Iarray.for_all (fun f -> f < 5.) ifarray;; - : bool = false |}];; +Iarray.for_all_local (fun i -> i > 0) (iarray_local ());; +[%%expect{| +- : bool = true +|}];; + +Iarray.for_all_local (fun f -> f < 5.) (ifarray_local ());; +[%%expect{| +- : bool = false +|}];; + Iarray.exists (fun f -> f < 5.) ifarray;; [%%expect{| - : bool = true @@ -330,6 +632,16 @@ Iarray.exists (fun i -> i > 10) iarray;; - : bool = false |}];; +Iarray.exists_local (fun f -> f < 5.) (ifarray_local ());; +[%%expect{| +- : bool = true +|}];; + +Iarray.exists_local (fun i -> i > 10) (iarray_local ());; +[%%expect{| +- : bool = false +|}];; + Iarray.for_all2 (fun i f -> Float.of_int i < f) iarray ifarray;; [%%expect{| - : bool = true @@ -340,6 +652,42 @@ Iarray.for_all2 (fun f i -> i = 1 && f = 1.5) ifarray iarray;; - : bool = false |}];; +Iarray.for_all2_local (fun i f -> Float.of_int i < f) + (iarray_local ()) (ifarray_local ());; +[%%expect{| +- : bool = true +|}];; + +Iarray.for_all2_local (fun f i -> i = 1 && f = 1.5) + (ifarray_local ()) (iarray_local ());; +[%%expect{| +- : bool = false +|}];; + +Iarray.for_all2_local_first (fun i f -> Float.of_int i < f) + (iarray_local ()) ifarray;; +[%%expect{| +- : bool = true +|}];; + +Iarray.for_all2_local_first (fun f i -> i = 1 && f = 1.5) + (ifarray_local ()) iarray;; +[%%expect{| +- : bool = false +|}];; + +Iarray.for_all2_local_second (fun i f -> Float.of_int i < f) + iarray (ifarray_local ());; +[%%expect{| +- : bool = true +|}];; + +Iarray.for_all2_local_second (fun f i -> i = 1 && f = 1.5) + ifarray (iarray_local ());; +[%%expect{| +- : bool = false +|}];; + Iarray.exists2 (fun f i -> Float.of_int i +. f = 8.5) ifarray iarray;; [%%expect{| - : bool = true @@ -350,6 +698,41 @@ Iarray.exists2 (fun i f -> Float.of_int i > f) iarray ifarray;; - : bool = false |}];; +Iarray.exists2_local (fun f i -> Float.of_int i +. f = 8.5) + (ifarray_local ()) (iarray_local ());; +[%%expect{| +- : bool = true +|}];; + +Iarray.exists2_local (fun i f -> Float.of_int i > f) + (iarray_local ()) (ifarray_local ());; +[%%expect{| +- : bool = false +|}];; + +Iarray.exists2_local_first (fun f i -> Float.of_int i +. f = 8.5) + (ifarray_local ()) iarray;; +[%%expect{| +- : bool = true +|}];; + +Iarray.exists2_local_first (fun i f -> Float.of_int i > f) + (iarray_local ()) ifarray;; +[%%expect{| +- : bool = false +|}];; +Iarray.exists2_local_second (fun f i -> Float.of_int i +. f = 8.5) + ifarray (iarray_local ());; +[%%expect{| +- : bool = true +|}];; + +Iarray.exists2_local_second (fun i f -> Float.of_int i > f) + iarray (ifarray_local ());; +[%%expect{| +- : bool = false +|}];; + Iarray.mem 3 iarray, Iarray.mem 3.5 ifarray;; [%%expect{| - : bool * bool = (true, true) @@ -383,6 +766,35 @@ Iarray.find_opt (fun x -> x*.x > 50.) ifarray;; - : int option * float option = (None, None) |}];; +let globalize_int_option (local_ opt) = match opt with + | None -> None + | Some (x : int) -> Some x + +let globalize_float_option (local_ opt) = match opt with + | None -> None + | Some x -> Some (globalize_float x) + +[%%expect{| +val globalize_int_option : local_ int option -> int option = +val globalize_float_option : local_ float option -> float option = +|}];; + +globalize_int_option (Iarray.find_opt_local (fun x -> x*x > 5) + (iarray_local ())), +globalize_float_option (Iarray.find_opt_local (fun x -> x*.x > 5.) + (ifarray_local ()));; +[%%expect{| +- : int option * float option = (Some 3, Some 2.5) +|}];; + +globalize_int_option (Iarray.find_opt_local (fun x -> x*x > 50) + (iarray_local ())), +globalize_float_option (Iarray.find_opt_local (fun x -> x*.x > 50.) + (ifarray_local ()));; +[%%expect{| +- : int option * float option = (None, None) +|}];; + Iarray.find_map (fun x -> if x mod 2 = 0 then Some (x / 2) else None) @@ -407,6 +819,90 @@ Iarray.find_map (fun x -> if Float.rem x 7. = 0.5 - : int option * float option = (None, None) |}];; +external rem : + (float[@local_opt]) -> (float[@local_opt]) -> float = + "caml_fmod_float" "fmod" [@@unboxed] [@@noalloc];; +[%%expect{| +external rem : (float [@local_opt]) -> (float [@local_opt]) -> float + = "caml_fmod_float" "fmod" [@@unboxed] [@@noalloc] +|}];; + +globalize_int_option + (Iarray.find_map_local (fun x -> if x mod 2 = 0 + then Some (x / 2) + else None) + (iarray_local ())), +globalize_float_option + (Iarray.find_map_local (fun x -> if rem x 2. = 0.5 + then exclave_ Some ((x -. 0.5) /. 2.) + else None) + (ifarray_local ()));; +[%%expect{| +- : int option * float option = (Some 1, Some 1.) +|}];; + +globalize_int_option + (Iarray.find_map_local (fun x -> if x mod 7 = 0 + then Some (x / 7) + else None) + (iarray_local ())), +globalize_float_option + (Iarray.find_map_local (fun x -> if rem x 7. = 0.5 + then exclave_ Some ((x -. 0.5) /. 7.) + else None) + (ifarray_local ()));; +[%%expect{| +- : int option * float option = (None, None) +|}];; + +Iarray.find_map_local_input (fun x -> if x mod 2 = 0 + then Some (x / 2) + else None) + (iarray_local ()), +Iarray.find_map_local_input (fun x -> if rem x 2. = 0.5 + then Some ((globalize_float x -. 0.5) /. 2.) + else None) + (ifarray_local ());; +[%%expect{| +- : int option * float option = (Some 1, Some 1.) +|}];; + +Iarray.find_map_local_input (fun x -> if x mod 7 = 0 + then Some (x / 7) + else None) + (iarray_local ()), +Iarray.find_map_local_input (fun x -> if rem x 7. = 0.5 + then Some ((globalize_float x -. 0.5) /. 7.) + else None) + (ifarray_local ());; +[%%expect{| +- : int option * float option = (None, None) +|}];; + +globalize_int_option + (Iarray.find_map_local_output (fun x -> if x mod 2 = 0 + then Some (x / 2) + else None) iarray), +globalize_float_option + (Iarray.find_map_local_output (fun x -> if rem x 2. = 0.5 + then exclave_ Some ((x -. 0.5) /. 2.) + else None) ifarray);; +[%%expect{| +- : int option * float option = (Some 1, Some 1.) +|}];; + +globalize_int_option + (Iarray.find_map_local_output (fun x -> if x mod 7 = 0 + then Some (x / 7) + else None) iarray), +globalize_float_option + (Iarray.find_map_local_output (fun x -> if rem x 7. = 0.5 + then exclave_ Some ((x -. 0.5) /. 7.) + else None) ifarray);; +[%%expect{| +- : int option * float option = (None, None) +|}];; + Iarray.split [: 1, "a"; 2, "b"; 3, "c" :];; [%%expect{| - : int iarray * string iarray = ([:1; 2; 3:], [:"a"; "b"; "c":]) @@ -417,6 +913,18 @@ Iarray.split [::];; - : 'a iarray * 'b iarray = ([::], [::]) |}];; +let is, ss = Iarray.split_local (stack_ [: 1, "a"; 2, "b"; 3, "c" :]) in +globalize_int_iarray is, Iarray.map_local_input globalize_string ss;; +[%%expect{| +- : int iarray * string iarray = ([:1; 2; 3:], [:"a"; "b"; "c":]) +|}];; + +let is, ss = Iarray.split_local (stack_ [::]) in +globalize_int_iarray is, Iarray.map_local_input globalize_string ss;; +[%%expect{| +- : int iarray * string iarray = ([::], [::]) +|}];; + Iarray.combine iarray ifarray;; [%%expect{| - : (int * float) iarray = @@ -433,6 +941,23 @@ Iarray.combine iarray [: "wrong length" :];; Exception: Invalid_argument "Iarray.combine". |}];; +globalize_int_float_iarray + (Iarray.combine_local (iarray_local ()) (ifarray_local ()));; +[%%expect{| +- : (int * float) iarray = +[:(1, 1.5); (2, 2.5); (3, 3.5); (4, 4.5); (5, 5.5):] +|}];; + +globalize_int_float_iarray (Iarray.combine_local [::] [::]);; +[%%expect{| +- : (int * float) iarray = [::] +|}];; + +globalize_int_float_iarray (Iarray.combine_local iarray [: 1.5 :]);; +[%%expect{| +Exception: Invalid_argument "Iarray.combine_local". +|}];; + Iarray.sort (Fun.flip Int.compare) iarray, Iarray.sort (Fun.flip Float.compare) ifarray;; [%%expect{| From 593497b9fde2fc2d8e9a263a3bc44737e13d833f Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 10 Sep 2024 10:32:03 +0100 Subject: [PATCH 35/76] Bump magic numbers for 5.1.1minus-23 (#3021) --- ocaml/runtime/caml/exec.h | 2 +- ocaml/runtime4/caml/exec.h | 2 +- ocaml/utils/config.common.ml | 30 +++++++++++++++--------------- 3 files changed, 17 insertions(+), 17 deletions(-) diff --git a/ocaml/runtime/caml/exec.h b/ocaml/runtime/caml/exec.h index ea4ba929c66..ca231e06ea0 100644 --- a/ocaml/runtime/caml/exec.h +++ b/ocaml/runtime/caml/exec.h @@ -60,7 +60,7 @@ struct exec_trailer { /* Magic number for this release */ -#define EXEC_MAGIC "Caml1999X535" +#define EXEC_MAGIC "Caml1999X536" #endif /* CAML_INTERNALS */ diff --git a/ocaml/runtime4/caml/exec.h b/ocaml/runtime4/caml/exec.h index ea4ba929c66..ca231e06ea0 100644 --- a/ocaml/runtime4/caml/exec.h +++ b/ocaml/runtime4/caml/exec.h @@ -60,7 +60,7 @@ struct exec_trailer { /* Magic number for this release */ -#define EXEC_MAGIC "Caml1999X535" +#define EXEC_MAGIC "Caml1999X536" #endif /* CAML_INTERNALS */ diff --git a/ocaml/utils/config.common.ml b/ocaml/utils/config.common.ml index e0c29d6b3d4..af48f382cb2 100644 --- a/ocaml/utils/config.common.ml +++ b/ocaml/utils/config.common.ml @@ -31,28 +31,28 @@ let standard_library = (* When artifacts are incompatible with upstream OCaml, ocaml-jst uses magic numbers ending in 5xx. (The AST remains compatible, so use upstream numbers) *) -let exec_magic_number = "Caml1999X535" +let exec_magic_number = "Caml1999X536" (* exec_magic_number is duplicated in runtime/caml/exec.h *) -and cmi_magic_number = "Caml1999I535" -and cmo_magic_number = "Caml1999O535" -and cma_magic_number = "Caml1999A535" +and cmi_magic_number = "Caml1999I536" +and cmo_magic_number = "Caml1999O536" +and cma_magic_number = "Caml1999A536" and cmx_magic_number = if flambda || flambda2 then - "Caml2021y536" + "Caml2021y537" else - "Caml2021Y535" + "Caml2021Y536" and cmxa_magic_number = if flambda || flambda2 then - "Caml2021z536" + "Caml2021z537" else - "Caml2021Z535" -and ast_impl_magic_number = "Caml1999M535" -and ast_intf_magic_number = "Caml1999N535" -and cmxs_magic_number = "Caml1999D535" -and cmt_magic_number = "Caml1999T535" -and cms_magic_number = "Caml1999S535" -and linear_magic_number = "Caml1999L535" -and cfg_magic_number = "Caml2021G535" + "Caml2021Z536" +and ast_impl_magic_number = "Caml1999M536" +and ast_intf_magic_number = "Caml1999N536" +and cmxs_magic_number = "Caml1999D536" +and cmt_magic_number = "Caml1999T536" +and cms_magic_number = "Caml1999S536" +and linear_magic_number = "Caml1999L536" +and cfg_magic_number = "Caml2021G536" let safe_string = true let default_safe_string = true From af06aef5b8789d0cabe1c487f3ebb24569848ff2 Mon Sep 17 00:00:00 2001 From: Guillaume Bury Date: Tue, 10 Sep 2024 11:35:10 +0200 Subject: [PATCH 36/76] Fix for allocation of closures containing unboxed values (#2997) * Fix for allocation of closures containings unboxed values The current code for allocating dynamic sets of closure did not properly take into account the fact that some of the env fields can now be unbxoed values. In some cases (particularly when the sets are bigger than Max_young_wosize), these unboxed fields require cmm code that sets the corresponding field, and that store operation need to be annotated with the correct memory_chunk. This commit adds the necessary code to propagate enough information so that we have access to the memory_chunks of every field when allocating a dynmaic set of closures (static closures do not need that, which is helpful since it would be much harder to produce the memory_chunks in those cases). At the same time, it reworks the current way these allocations are generated: the old code used a `set` function, which in effect was only there to distinguish on what is essentially the memory_chunk of the value being written and use the appropriate cmm expression to write the value. The code is simplified by instead providing the adequate memory_chunk, from which the set function can be deduced. * Take into account the actual size of env slots in closures * Remove option type for chunks in to_cmm_set_of_closures * fixes * Rename the type/cstrs for regular blocks vs mixed blocks * Rename value slot in slot_offsets Cherry_picked from PR#2983 * typo * typos * Add doc + assertion for the shape of a mixed block * Fix computation of subkinds for mixed blocks fields * Code review --------- Co-authored-by: Mark Shinwell --- backend/cmm_helpers.ml | 222 +++++++++++------- backend/cmm_helpers.mli | 29 ++- .../flambda2/simplify_shared/slot_offsets.ml | 32 ++- .../flambda2/to_cmm/to_cmm_primitive.ml | 57 +++-- .../flambda2/to_cmm/to_cmm_set_of_closures.ml | 94 ++++++-- middle_end/flambda2/to_cmm/to_cmm_shared.ml | 5 +- middle_end/flambda2/to_cmm/to_cmm_shared.mli | 2 +- 7 files changed, 288 insertions(+), 153 deletions(-) diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index f4a90f43db2..eb93bdc2042 100644 --- a/backend/cmm_helpers.ml +++ b/backend/cmm_helpers.ml @@ -66,8 +66,13 @@ let mk_load_atomic memory_chunk = let floatarray_tag dbg = Cconst_int (Obj.double_array_tag, dbg) type t = - | Scan_all - | Scan_prefix of int + | Regular_block + (* Regular blocks, including closures (with unboxed fields). Closures do *not* + need to be mixed block because they can make use of the startenv to skip + the unboxed part of the environment. *) + | Mixed_block of { scannable_prefix : int } +(* Mixed blocks, that need special header to specify the length of the scannable + prefix. *) module Mixed_block_support : sig val assert_mixed_block_support : unit -> unit @@ -136,15 +141,15 @@ end = struct end (* CR mshinwell: update to use NOT_MARKABLE terminology *) -let block_header ?(scannable_prefix = Scan_all) tag sz = +let block_header ?(block_kind = Regular_block) tag sz = let hdr = Nativeint.add (Nativeint.shift_left (Nativeint.of_int sz) 10) (Nativeint.of_int tag) in - match scannable_prefix with - | Scan_all -> hdr - | Scan_prefix scannable_prefix -> + match block_kind with + | Regular_block -> hdr + | Mixed_block { scannable_prefix } -> Mixed_block_support.make_header hdr ~scannable_prefix (* Static data corresponding to "value"s must be marked black in case we are in @@ -154,11 +159,12 @@ let black_block_header tag sz = Nativeint.logor (block_header tag sz) caml_black let black_mixed_block_header tag sz ~scannable_prefix_len = Nativeint.logor - (block_header tag sz ~scannable_prefix:(Scan_prefix scannable_prefix_len)) + (block_header tag sz + ~block_kind:(Mixed_block { scannable_prefix = scannable_prefix_len })) caml_black -let local_block_header ?scannable_prefix tag sz = - Nativeint.logor (block_header ?scannable_prefix tag sz) caml_local +let local_block_header ?block_kind tag sz = + Nativeint.logor (block_header ?block_kind tag sz) caml_local let white_closure_header sz = block_header Obj.closure_tag sz @@ -1568,37 +1574,91 @@ let call_cached_method obj tag cache pos args args_type result (apos, mode) dbg (* Allocation *) -let make_alloc_generic ?(scannable_prefix = Scan_all) ~mode set_fn dbg tag - wordsize args = +(* CR layouts 5.1: When we pack int32s/float32s more efficiently, this code will + need to change. *) +let memory_chunk_size_in_words_for_mixed_block = function + | (Byte_unsigned | Byte_signed | Sixteen_unsigned | Sixteen_signed) as + memory_chunk -> + Misc.fatal_errorf + "Fields with memory chunk %s are not allowed in mixed blocks" + (Printcmm.chunk memory_chunk) + | Thirtytwo_unsigned | Thirtytwo_signed -> + (* Int32s are currently stored using a whole word *) + 1 + | Single _ | Double -> + (* Float32s are currently stored using a whole word *) + if size_float <> size_addr + then + Misc.fatal_error + "Unable to compile mixed blocks on a platform where a float is not the \ + same width as a value."; + 1 + | Word_int | Word_val -> 1 + | Onetwentyeight_unaligned | Onetwentyeight_aligned -> 2 + +let alloc_generic_set_fn block ofs newval memory_chunk dbg = + let generic_case () = + let addr = array_indexing log2_size_addr block ofs dbg in + Cop (Cstore (memory_chunk, Initialization), [addr; newval], dbg) + in + match (memory_chunk : Cmm.memory_chunk) with + | Word_val -> + (* Values must go through "caml_initialize" *) + addr_array_initialize block ofs newval dbg + | Word_int -> generic_case () + (* Generic cases that may differ under big endian archs *) + | Single _ | Double | Thirtytwo_unsigned | Thirtytwo_signed + | Onetwentyeight_unaligned | Onetwentyeight_aligned -> + if Arch.big_endian + then + Misc.fatal_errorf + "Fields with memory_chunk %s are not supported on big-endian \ + architectures" + (Printcmm.chunk memory_chunk); + generic_case () + (* Forbidden cases *) + | Byte_unsigned | Byte_signed | Sixteen_unsigned | Sixteen_signed -> + Misc.fatal_errorf + "Fields with memory_chunk %s are not supported in generic allocations" + (Printcmm.chunk memory_chunk) + +let make_alloc_generic ~block_kind ~mode dbg tag wordsize args + args_memory_chunks = (* allocs of size 0 must be statically allocated else the Gc will bug *) assert (List.compare_length_with args 0 > 0); if Lambda.is_local_mode mode || wordsize <= Config.max_young_wosize then let hdr = match mode with - | Lambda.Alloc_local -> local_block_header ~scannable_prefix tag wordsize - | Lambda.Alloc_heap -> block_header ~scannable_prefix tag wordsize + | Lambda.Alloc_local -> local_block_header ~block_kind tag wordsize + | Lambda.Alloc_heap -> block_header ~block_kind tag wordsize in Cop (Calloc mode, Cconst_natint (hdr, dbg) :: args, dbg) else let id = V.create_local "*alloc*" in - let rec fill_fields idx = function - | [] -> Cvar id - | e1 :: el -> + let rec fill_fields idx args memory_chunks = + match args, memory_chunks with + | [], [] -> Cvar id + | e1 :: el, m1 :: ml -> + let ofs = memory_chunk_size_in_words_for_mixed_block m1 in Csequence - ( set_fn idx (Cvar id) (int_const dbg idx) e1 dbg, - fill_fields (idx + 1) el ) + ( alloc_generic_set_fn (Cvar id) (int_const dbg idx) e1 m1 dbg, + fill_fields (idx + ofs) el ml ) + | _ -> + Misc.fatal_errorf + "To_cmm_helpers.make_alloc_generic: mismatched list sizes between \ + fields and memory chunks" in let caml_alloc_func, caml_alloc_args = - match Config.runtime5, scannable_prefix with - | true, Scan_all -> "caml_alloc_shr_check_gc", [wordsize; tag] - | false, Scan_all -> "caml_alloc", [wordsize; tag] - | true, Scan_prefix prefix_len -> + match Config.runtime5, block_kind with + | true, Regular_block -> "caml_alloc_shr_check_gc", [wordsize; tag] + | false, Regular_block -> "caml_alloc", [wordsize; tag] + | true, Mixed_block { scannable_prefix } -> Mixed_block_support.assert_mixed_block_support (); - "caml_alloc_mixed_shr_check_gc", [wordsize; tag; prefix_len] - | false, Scan_prefix prefix_len -> + "caml_alloc_mixed_shr_check_gc", [wordsize; tag; scannable_prefix] + | false, Mixed_block { scannable_prefix } -> Mixed_block_support.assert_mixed_block_support (); - "caml_alloc_mixed", [wordsize; tag; prefix_len] + "caml_alloc_mixed", [wordsize; tag; scannable_prefix] in Clet ( VP.create id, @@ -1615,71 +1675,73 @@ let make_alloc_generic ?(scannable_prefix = Scan_all) ~mode set_fn dbg tag }, List.map (fun arg -> Cconst_int (arg, dbg)) caml_alloc_args, dbg ), - fill_fields 0 args ) - -let addr_array_init arr ofs newval dbg = - Cop - ( Cextcall - { func = "caml_initialize"; - ty = typ_void; - alloc = false; - builtin = false; - returns = true; - effects = Arbitrary_effects; - coeffects = Has_coeffects; - ty_args = [] - }, - [array_indexing log2_size_addr arr ofs dbg; newval], - dbg ) + fill_fields 0 args args_memory_chunks ) let make_alloc ~mode dbg ~tag args = - make_alloc_generic ~mode - (fun _ arr ofs newval dbg -> addr_array_init arr ofs newval dbg) - dbg tag (List.length args) args + make_alloc_generic ~block_kind:Regular_block ~mode dbg tag (List.length args) + args + (List.map (fun _ -> Word_val) args) let make_float_alloc ~mode dbg ~tag args = - make_alloc_generic ~mode - (fun _ -> float_array_set) - dbg tag + make_alloc_generic ~block_kind:Regular_block ~mode dbg tag (List.length args * size_float / size_addr) args + (List.map (fun _ -> Double) args) -module Flat_suffix_element = struct - type t = - | Tagged_immediate - | Naked_float - | Naked_float32 - | Naked_int32 - | Naked_int64_or_nativeint -end - -let make_mixed_alloc ~mode dbg ~tag ~value_prefix_size - ~(flat_suffix : Flat_suffix_element.t array) args = - (* args with shape [Float] must already have been unboxed. *) - let set_fn idx arr ofs newval dbg = - if idx < value_prefix_size - then addr_array_init arr ofs newval dbg - else - match flat_suffix.(idx - value_prefix_size) with - | Tagged_immediate -> int_array_set arr ofs newval dbg - | Naked_float -> float_array_set arr ofs newval dbg - | Naked_float32 -> setfield_unboxed_float32 arr ofs newval dbg - | Naked_int32 -> setfield_unboxed_int32 arr ofs newval dbg - | Naked_int64_or_nativeint -> - setfield_unboxed_int64_or_nativeint arr ofs newval dbg +let make_closure_alloc ~mode dbg ~tag args args_memory_chunks = + let size = + List.fold_left + (fun acc memory_chunk -> + acc + memory_chunk_size_in_words_for_mixed_block memory_chunk) + 0 args_memory_chunks in + make_alloc_generic ~block_kind:Regular_block ~mode dbg tag size args + args_memory_chunks + +let make_mixed_alloc ~mode dbg ~tag ~value_prefix_size args args_memory_chunks = let size = - (* CR layouts 5.1: When we pack int32s/float32s more efficiently, this code - will need to change. *) - value_prefix_size + Array.length flat_suffix + List.fold_left + (fun ofs memory_chunk -> + let ok () = + ofs + memory_chunk_size_in_words_for_mixed_block memory_chunk + in + let error situation = + Misc.fatal_errorf + "Fields with memory chunk %s are not allowed in %s.@\n\ + value_prefix_size: %d@\n\ + args: @[%a@]@\n\ + chunks: @[%a@]@." + (Printcmm.chunk memory_chunk) + situation value_prefix_size + (Format.pp_print_list Printcmm.expression) + args + (Format.pp_print_list Format.pp_print_string) + (List.map Printcmm.chunk args_memory_chunks) + in + if ofs < value_prefix_size + then + (* regular scanned part of a block *) + match memory_chunk with + | Word_int | Word_val -> ok () + | Byte_unsigned | Byte_signed | Sixteen_unsigned | Sixteen_signed -> + error "mixed blocks" + | Thirtytwo_unsigned | Thirtytwo_signed | Single _ | Double + | Onetwentyeight_unaligned | Onetwentyeight_aligned -> + error "the value prefix of a mixed block" + else + (* flat suffix part of the block *) + match memory_chunk with + | Word_int | Thirtytwo_unsigned | Thirtytwo_signed | Double + | Onetwentyeight_unaligned | Onetwentyeight_aligned | Single _ -> + ok () + | Byte_unsigned | Byte_signed | Sixteen_unsigned | Sixteen_signed -> + error "mixed blocks" + | Word_val -> error "the flat suffix of a mixed block") + 0 args_memory_chunks in - if size_float <> size_addr - then - Misc.fatal_error - "Unable to compile mixed blocks on a platform where a float is not the \ - same width as a value."; - make_alloc_generic ~scannable_prefix:(Scan_prefix value_prefix_size) ~mode - set_fn dbg tag size args + make_alloc_generic + ~block_kind:(Mixed_block { scannable_prefix = value_prefix_size }) + ~mode dbg tag size args args_memory_chunks (* Record application and currying functions *) diff --git a/backend/cmm_helpers.mli b/backend/cmm_helpers.mli index c9a6666e53e..d2a3bf26a3b 100644 --- a/backend/cmm_helpers.mli +++ b/backend/cmm_helpers.mli @@ -325,24 +325,31 @@ val make_float_alloc : expression list -> expression -module Flat_suffix_element : sig - type t = - | Tagged_immediate - | Naked_float - | Naked_float32 - | Naked_int32 - | Naked_int64_or_nativeint -end +(** Allocate a closure block, to hold a set of closures. + + This takes a list of expressions [exprs] and a list of [memory_chunk]s + that correspond pairwise. Both lists must be the same length. + + The list of expressions includes _all_ fields of the closure block, + including the code pointers and closure information fields. *) +val make_closure_alloc : + mode:Lambda.alloc_mode -> + Debuginfo.t -> + tag:int -> + expression list -> + memory_chunk list -> + expression -(** Allocate an mixed block of the corresponding tag and shape. Initial values - of the flat suffix should be provided unboxed. *) +(** Allocate an mixed block of the corresponding tag and scannable prefix size. + The [memory_chunk] list should give the memory_chunk corresponding to + each element from the [expression] list. *) val make_mixed_alloc : mode:Lambda.alloc_mode -> Debuginfo.t -> tag:int -> value_prefix_size:int -> - flat_suffix:Flat_suffix_element.t array -> expression list -> + memory_chunk list -> expression (** Sys.opaque_identity *) diff --git a/middle_end/flambda2/simplify_shared/slot_offsets.ml b/middle_end/flambda2/simplify_shared/slot_offsets.ml index d9bff0a72d5..81df7a6e470 100644 --- a/middle_end/flambda2/simplify_shared/slot_offsets.ml +++ b/middle_end/flambda2/simplify_shared/slot_offsets.ml @@ -318,7 +318,7 @@ end = struct type _ slot_desc = | Function_slot : Function_slot.t -> function_slot slot_desc | Unboxed_slot : Value_slot.t -> unboxed_slot slot_desc - | Value_slot : Value_slot.t -> value_slot slot_desc + | Scannable_value_slot : Value_slot.t -> value_slot slot_desc (* This module helps to distinguish between the two different notions of offsets that are used for function slots: @@ -358,14 +358,15 @@ end = struct let offset = match slot with | Function_slot _ -> first_offset_used_including_header + 1 - | Unboxed_slot _ | Value_slot _ -> first_offset_used_including_header + | Unboxed_slot _ | Scannable_value_slot _ -> + first_offset_used_including_header in Offset offset let range_used_by (type a) (slot : a slot_desc) (Offset pos) ~slot_size = match slot with | Function_slot _ -> pos - 1, pos + slot_size - | Unboxed_slot _ | Value_slot _ -> pos, pos + slot_size + | Unboxed_slot _ | Scannable_value_slot _ -> pos, pos + slot_size let add_slot_to_exported_offsets (type a) offsets (slot : a slot_desc) (Offset pos) ~slot_size = @@ -381,7 +382,7 @@ end = struct { offset = pos; is_scanned = false; size = slot_size } in EO.add_value_slot_offset offsets unboxed_slot info - | Value_slot value_slot -> + | Scannable_value_slot value_slot -> let (info : EO.value_slot_info) = EO.Live_value_slot { offset = pos; is_scanned = true; size = slot_size } @@ -488,7 +489,7 @@ end = struct let print_desc (type a) fmt (slot_desc : a slot_desc) = match slot_desc with | Function_slot c -> Format.fprintf fmt "%a" Function_slot.print c - | Unboxed_slot v | Value_slot v -> + | Unboxed_slot v | Scannable_value_slot v -> Format.fprintf fmt "%a" Value_slot.print v let print_slot_pos fmt = function @@ -556,7 +557,7 @@ end = struct | Unassigned | Removed -> () | Assigned offset -> ( match slot.desc with - | Value_slot _ -> + | Scannable_value_slot _ -> if slot.size <> 1 then Misc.fatal_errorf "Value slot has size %d, which is not 1." slot.size; @@ -625,7 +626,7 @@ end = struct let (info : EO.function_slot_info) = EO.Dead_function_slot in state.used_offsets <- EO.add_function_slot_offset state.used_offsets function_slot info - | Unboxed_slot v | Value_slot v -> + | Unboxed_slot v | Scannable_value_slot v -> let (info : EO.value_slot_info) = EO.Dead_value_slot in state.used_offsets <- EO.add_value_slot_offset state.used_offsets v info ) @@ -642,7 +643,7 @@ end = struct state.function_slots_to_assign <- slot :: state.function_slots_to_assign | Unboxed_slot _ -> state.unboxed_slots_to_assign <- slot :: state.unboxed_slots_to_assign - | Value_slot _ -> + | Scannable_value_slot _ -> state.value_slots_to_assign <- slot :: state.value_slots_to_assign let add_allocated_slot_to_set slot set = @@ -809,7 +810,9 @@ end = struct let create_value_slot set state value_slot = if Compilation_unit.is_current (Value_slot.get_compilation_unit value_slot) then ( - let s = create_slot ~size:1 (Value_slot value_slot) Unassigned in + let s = + create_slot ~size:1 (Scannable_value_slot value_slot) Unassigned + in add_value_slot state value_slot s; add_unallocated_slot_to_set state s set; s) @@ -837,7 +840,10 @@ end = struct in the original compilation unit, this should not happen." Value_slot.print value_slot; let offset = Exported_offset.from_exported_offset offset in - let s = create_slot ~size:1 (Value_slot value_slot) (Assigned offset) in + let s = + create_slot ~size:1 (Scannable_value_slot value_slot) + (Assigned offset) + in use_value_slot_info state value_slot info; add_value_slot state value_slot s; add_allocated_slot_to_set s set; @@ -939,7 +945,7 @@ end = struct let needed_space = match slot.desc with | Function_slot _ -> slot.size + 1 (* header word *) - | Unboxed_slot _ | Value_slot _ -> slot.size + | Unboxed_slot _ | Scannable_value_slot _ -> slot.size in (* Ensure that for value slots, we are after all function slots. *) let curr = @@ -949,7 +955,7 @@ end = struct (* first_slot_after_function_slots is always >=0, thus ensuring we do not place a value slot at offset -1 *) max start set.first_slot_after_function_slots - | Value_slot _ -> max start set.first_slot_after_unboxed_slots + | Scannable_value_slot _ -> max start set.first_slot_after_unboxed_slots in (* Adjust a starting position to not point in the middle of a block. Additionally, ensure the value slot slots are put after the function @@ -1052,7 +1058,7 @@ end = struct state.value_slots_to_assign <- []; List.iter (function - | { desc = Value_slot v; _ } as slot -> + | { desc = Scannable_value_slot v; _ } as slot -> if value_slot_is_used ~used_value_slots v then assign_slot_offset state slot else mark_slot_as_removed state slot) diff --git a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml index 1612fb06f12..629879a53de 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml @@ -16,6 +16,7 @@ module Env = To_cmm_env module Ece = Effects_and_coeffects module EO = Exported_offsets module K = Flambda_kind +module KS = Flambda_kind.With_subkind module P = Flambda_primitive (* Note about [Int32]: values of this kind are stored in 64-bit registers and @@ -85,30 +86,44 @@ let check_alloc_fields = function be lifted so they can be statically allocated)" | _ -> () +let mixed_block_kinds shape = + let value_prefix = + (* CR mshinwell: We should propagate information about whether a field is a + tagged immediate. *) + List.init (K.Mixed_block_shape.value_prefix_size shape) (fun _ -> + K.With_subkind.any_value) + in + let flat_suffix = + List.map + (fun (flat_suffix_element : K.flat_suffix_element) -> + match flat_suffix_element with + | Tagged_immediate -> KS.tagged_immediate + | Naked_float -> KS.naked_float + | Naked_float32 -> KS.naked_float32 + | Naked_int32 -> KS.naked_int32 + | Naked_int64 -> KS.naked_int64 + | Naked_nativeint -> KS.naked_nativeint) + (Array.to_list (K.Mixed_block_shape.flat_suffix shape)) + in + value_prefix @ flat_suffix + let make_block ~dbg kind alloc_mode args = check_alloc_fields args; let mode = Alloc_mode.For_allocations.to_lambda alloc_mode in - let allocator, tag = - match (kind : P.Block_kind.t) with - | Values (tag, _) -> C.make_alloc, Tag.Scannable.to_tag tag - | Naked_floats -> C.make_float_alloc, Tag.double_array_tag - | Mixed (tag, shape) -> - let value_prefix_size = K.Mixed_block_shape.value_prefix_size shape in - let flat_suffix = - Array.map - (fun (flat_elt : K.Flat_suffix_element.t) : C.Flat_suffix_element.t -> - match flat_elt with - | Tagged_immediate -> Tagged_immediate - | Naked_float -> Naked_float - | Naked_float32 -> Naked_float32 - | Naked_int32 -> Naked_int32 - | Naked_int64 | Naked_nativeint -> Naked_int64_or_nativeint) - (K.Mixed_block_shape.flat_suffix shape) - in - ( C.make_mixed_alloc ~value_prefix_size ~flat_suffix, - Tag.Scannable.to_tag tag ) - in - allocator ~mode dbg ~tag:(Tag.to_int tag) args + match (kind : P.Block_kind.t) with + | Values (tag, _) -> + let tag = Tag.Scannable.to_int tag in + C.make_alloc ~mode dbg ~tag args + | Naked_floats -> + let tag = Tag.to_int Tag.double_array_tag in + C.make_float_alloc ~mode dbg ~tag args + | Mixed (tag, shape) -> + let value_prefix_size = K.Mixed_block_shape.value_prefix_size shape in + let args_memory_chunks = + List.map C.memory_chunk_of_kind (mixed_block_kinds shape) + in + let tag = Tag.Scannable.to_int tag in + C.make_mixed_alloc ~mode dbg ~tag ~value_prefix_size args args_memory_chunks let block_load ~dbg (kind : P.Block_access_kind.t) (mutability : Mutability.t) ~block ~index = diff --git a/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml b/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml index 7de89e26919..f2629ff292a 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml @@ -97,7 +97,7 @@ module Make_layout_filler (P : sig To_cmm_env.t -> To_cmm_result.t -> Simple.t -> - [`Data of cmm_term list | `Var of Variable.t] + [`Expr of cmm_term | `Static_data of cmm_term list | `Var of Variable.t] * To_cmm_env.free_vars * To_cmm_env.t * To_cmm_result.t @@ -121,6 +121,7 @@ end) : sig prev_updates:To_cmm_env.expr_with_info option -> (int * Slot_offsets.Layout.slot) list -> P.cmm_term list + * Cmm.memory_chunk list * To_cmm_env.free_vars * int * Env.t @@ -128,20 +129,24 @@ end) : sig * Ece.t * To_cmm_env.expr_with_info option end = struct + let rev_append_chunks ~for_static_sets l chunks = + match for_static_sets with None -> List.rev_append l chunks | Some _ -> [] + (* The [offset]s here are measured in units of words. *) let fill_slot for_static_sets decls dbg ~startenv value_slots env res acc - ~slot_offset updates slot = + chunk_acc ~slot_offset updates slot = match (slot : Slot_offsets.Layout.slot) with | Infix_header -> let field = P.infix_header ~function_slot_offset:(slot_offset + 1) ~dbg in ( field :: acc, + rev_append_chunks ~for_static_sets [Cmm.Word_int] chunk_acc, Backend_var.Set.empty, slot_offset + 1, env, res, Ece.pure, updates ) - | Value_slot { value_slot; is_scanned; size = _ } -> + | Value_slot { value_slot; is_scanned; size } -> let simple = Value_slot.Map.find value_slot value_slots in let kind = Value_slot.kind value_slot in if (not @@ -154,9 +159,15 @@ end = struct "Value slot %a not of kind Value (%a) but is visible by GC" Simple.print simple Debuginfo.print_compact dbg; let contents, free_vars, env, res, eff = P.simple ~dbg env res simple in - let env, res, fields, updates = + let env, res, fields, chunk_acc, updates = match contents with - | `Data fields -> env, res, fields, updates + | `Expr field -> + let chunk = C.memory_chunk_of_kind kind in + let chunk_acc = + rev_append_chunks ~for_static_sets [chunk] chunk_acc + in + env, res, [field], chunk_acc, updates + | `Static_data fields -> env, res, fields, chunk_acc, updates | `Var v -> ( (* We should only get here in the static allocation case. *) match for_static_sets with @@ -194,11 +205,13 @@ end = struct ~index:(slot_offset - function_slot_offset_for_updates) ~prev_updates:updates in - env, res, [P.int ~dbg 1n], updates) + let fields = List.init size (fun _ -> P.int ~dbg 1n) in + env, res, fields, chunk_acc, updates) in ( List.rev_append fields acc, + chunk_acc, free_vars, - slot_offset + 1, + slot_offset + size, env, res, eff, @@ -243,6 +256,9 @@ end = struct P.int ~dbg closure_info :: P.term_of_symbol ~dbg code_symbol :: acc in ( acc, + rev_append_chunks ~for_static_sets + [Cmm.Word_int; Cmm.Word_int] + chunk_acc, Backend_var.Set.empty, slot_offset + size, env, @@ -265,6 +281,9 @@ end = struct :: acc in ( acc, + rev_append_chunks ~for_static_sets + [Cmm.Word_int; Cmm.Word_int; Cmm.Word_int] + chunk_acc, Backend_var.Set.empty, slot_offset + size, env, @@ -283,14 +302,22 @@ end = struct ~arity:(if size = 2 then 1 else 2) ~startenv:(startenv - slot_offset) ~is_last:last_function_slot in - let acc = + let acc, chunk_acc = match size with - | 2 -> P.int ~dbg closure_info :: P.int ~dbg 0n :: acc + | 2 -> + ( P.int ~dbg closure_info :: P.int ~dbg 0n :: acc, + rev_append_chunks ~for_static_sets + [Cmm.Word_int; Cmm.Word_int] + chunk_acc ) | 3 -> - P.int ~dbg 0n :: P.int ~dbg closure_info :: P.int ~dbg 0n :: acc + ( P.int ~dbg 0n :: P.int ~dbg closure_info :: P.int ~dbg 0n :: acc, + rev_append_chunks ~for_static_sets + [Cmm.Word_int; Cmm.Word_int; Cmm.Word_int] + chunk_acc ) | _ -> assert false in ( acc, + chunk_acc, Backend_var.Set.empty, slot_offset + size, env, @@ -299,38 +326,49 @@ end = struct updates )) let rec fill_layout0 for_static_sets decls dbg ~startenv value_slots env res - effs acc updates ~free_vars ~starting_offset slots = + effs acc chunk_acc updates ~free_vars ~starting_offset slots = match slots with - | [] -> List.rev acc, free_vars, starting_offset, env, res, effs, updates + | [] -> + ( List.rev acc, + List.rev chunk_acc, + free_vars, + starting_offset, + env, + res, + effs, + updates ) | (slot_offset, slot) :: slots -> - let acc = + let acc, chunk_acc = if starting_offset > slot_offset then Misc.fatal_errorf "Starting offset %d is past slot offset %d" starting_offset slot_offset else if starting_offset = slot_offset - then acc + then acc, chunk_acc else (* The space between slot offsets has to be padded with precisely the value tagged 0, as it is scanned by the GC during compaction. This value can't be confused with either infix headers or inverted pointers, as noted in the comment in compact.c *) - List.init (slot_offset - starting_offset) (fun _ -> P.int ~dbg 1n) - @ acc + ( List.init (slot_offset - starting_offset) (fun _ -> P.int ~dbg 1n) + @ acc, + rev_append_chunks ~for_static_sets + (List.init (slot_offset - starting_offset) (fun _ -> Cmm.Word_int)) + chunk_acc ) in - let acc, slot_free_vars, next_offset, env, res, eff, updates = + let acc, chunk_acc, slot_free_vars, next_offset, env, res, eff, updates = fill_slot for_static_sets decls dbg ~startenv value_slots env res acc - ~slot_offset updates slot + chunk_acc ~slot_offset updates slot in let free_vars = Backend_var.Set.union free_vars slot_free_vars in let effs = Ece.join eff effs in fill_layout0 for_static_sets decls dbg ~startenv value_slots env res effs - acc updates ~free_vars ~starting_offset:next_offset slots + acc chunk_acc updates ~free_vars ~starting_offset:next_offset slots let fill_layout for_static_sets decls dbg ~startenv value_slots env res effs ~prev_updates slots = fill_layout0 for_static_sets decls dbg ~startenv value_slots env res effs [] - prev_updates ~free_vars:Backend_var.Set.empty ~starting_offset:0 slots + [] prev_updates ~free_vars:Backend_var.Set.empty ~starting_offset:0 slots end (* Filling-up of dynamically-allocated sets of closures. *) @@ -350,7 +388,7 @@ module Dynamic = Make_layout_filler (struct let To_cmm_env.{ env; res; expr = { cmm; free_vars; effs } } = C.simple ~dbg env res simple in - `Data [cmm], free_vars, env, res, effs + `Expr cmm, free_vars, env, res, effs let infix_header ~dbg ~function_slot_offset = C.alloc_infix_header function_slot_offset dbg @@ -547,11 +585,17 @@ let let_static_set_of_closures0 env res closure_symbols closure_symbol_for_updates } in - let l, free_vars, length, env, res, _effs, updates = + let l, memory_chunks, free_vars, length, env, res, _effs, updates = Static.fill_layout (Some for_static_sets) decls dbg ~startenv:layout.startenv value_slots env res Ece.pure ~prev_updates layout.slots in + (match memory_chunks with + | [] -> () + | _ :: _ -> + Misc.fatal_errorf + "Broken internal invariant: Static sets of closures do not need a list \ + of memory chunks"); if not (Backend_var.Set.is_empty free_vars) then Misc.fatal_errorf @@ -650,7 +694,7 @@ let let_dynamic_set_of_closures0 env res ~body ~bound_vars set let decl_map = decls |> Function_slot.Lmap.bindings |> Function_slot.Map.of_list in - let l, free_vars, _offset, env, res, effs, updates = + let l, memory_chunks, free_vars, _offset, env, res, effs, updates = Dynamic.fill_layout None decl_map dbg ~startenv:layout.startenv value_slots env res effs ~prev_updates:None layout.slots in @@ -658,9 +702,9 @@ let let_dynamic_set_of_closures0 env res ~body ~bound_vars set let csoc = assert (List.compare_length_with l 0 > 0); let tag = Tag.(to_int closure_tag) in - C.make_alloc + C.make_closure_alloc ~mode:(Alloc_mode.For_allocations.to_lambda closure_alloc_mode) - dbg ~tag l + dbg ~tag l memory_chunks in let soc_var = Variable.create "*set_of_closures*" in let defining_expr = Env.simple csoc free_vars in diff --git a/middle_end/flambda2/to_cmm/to_cmm_shared.ml b/middle_end/flambda2/to_cmm/to_cmm_shared.ml index 5c39709bd94..afa2088c29a 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_shared.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_shared.ml @@ -201,7 +201,8 @@ let simple ?consider_inlining_effectful_expressions ~dbg env res s = let name_static res name = Name.pattern_match name ~var:(fun v -> `Var v) - ~symbol:(fun s -> `Data [symbol_address (To_cmm_result.symbol res s)]) + ~symbol:(fun s -> + `Static_data [symbol_address (To_cmm_result.symbol res s)]) let const_static cst = match Reg_width_const.descr cst with @@ -235,7 +236,7 @@ let const_static cst = let simple_static res s = Simple.pattern_match s ~name:(fun n ~coercion:_ -> name_static res n) - ~const:(fun c -> `Data (const_static c)) + ~const:(fun c -> `Static_data (const_static c)) let simple_list ?consider_inlining_effectful_expressions ~dbg env res l = (* Note that [To_cmm_primitive] relies on this function translating the diff --git a/middle_end/flambda2/to_cmm/to_cmm_shared.mli b/middle_end/flambda2/to_cmm/to_cmm_shared.mli index 26cbadc3e2f..7c81a795e97 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_shared.mli +++ b/middle_end/flambda2/to_cmm/to_cmm_shared.mli @@ -73,7 +73,7 @@ val simple : val simple_static : To_cmm_result.t -> Simple.t -> - [`Data of Cmm.data_item list | `Var of Variable.t] + [> `Static_data of Cmm.data_item list | `Var of Variable.t] (** This function translates the [Simple] at the head of the list first. Regarding [consider_inlining_effectful_expressions], see [simple] above. *) From 3e7f92e0e3bc7a7a566c5bffebbadd6ccad23cf2 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 10 Sep 2024 11:40:11 +0100 Subject: [PATCH 37/76] parsetree/test should produce empty output --- .../testsuite/tests/parsetree/test.reference | 5274 ----------------- 1 file changed, 5274 deletions(-) diff --git a/ocaml/testsuite/tests/parsetree/test.reference b/ocaml/testsuite/tests/parsetree/test.reference index 574a05903b3..e69de29bb2d 100644 --- a/ocaml/testsuite/tests/parsetree/test.reference +++ b/ocaml/testsuite/tests/parsetree/test.reference @@ -1,5274 +0,0 @@ -source.ml: FAIL, CANNOT REPARSE -File "", line 5261, characters 22-25: -Error: Syntax error -[@@@foo ] -let ((x)[@foo ]) : ((unit)[@foo ]) = ((())[@foo ])[@@foo ] -type t = - | Foo of ((t)[@foo ]) [@foo ][@@foo ] -[@@@foo ] -module M = - ((struct type t = { - l: ((t)[@foo ]) [@foo ]}[@@foo ][@@foo ] - [@@@foo ] end)[@foo ])[@@foo ] -module type S = - ((sig - include - ((((module type of ((M)[@foo ]))[@foo ]) with type t := M.t) - [@foo ])[@@foo ] - [@@@foo ] - end)[@foo ])[@@foo ] -[@@@foo ] -type 'a with_default = - ?size:((int)[@ocaml.doc " default [42] "]) -> - ?resizable:((bool)[@ocaml.doc " default [true] "]) -> 'a -type obj = - < - meth1: int -> int [@ocaml.doc " method 1 "] ;meth2: unit -> float - [@ocaml.doc " method 2 "] - > -type var = - [ `Foo [@ocaml.doc " foo "] | `Bar of (int * string) [@ocaml.doc " bar "]] -[%%foo let x = 1 in x] -let [%foo 2 + 1] : [%foo bar.baz] = [%foo "foo"] -[%%foo module M = [%bar ]] -let [%foo let () = ()] : [%foo type t = t] = [%foo class c = object end] -[%%foo : 'a list] -let [%foo : [ `Foo ]] : [%foo : t -> t] = [%foo : < foo: t > ] -[%%foo ? _] -[%%foo ? Some y when y > 0] -let [%foo ? Bar x | Baz x] : [%foo ? #bar] = [%foo ? { x }] -[%%foo : module M : [%baz ]] -let [%foo : include S with type t = t] : [%foo : val x : t - val y : t] - = [%foo : type t = t] -let int_with_custom_modifier = - 1234567890_1234567890_1234567890_1234567890_1234567890z -let float_with_custom_modifier = - 1234567890_1234567890_1234567890_1234567890_1234567890.z -let int32 = 1234l -let int64 = 1234L -let nativeint = 1234n -let hex_without_modifier = 0x32f -let hex_with_modifier = 0x32g -let float_without_modifer = 1.2e3 -let float_with_modifer = 1.2g -[%%foo let x = 42] -[%%foo let _ = () - and _ = ()] -[%%foo let _ = ()] -let () = - [%foo - let x = 3[@@foo ] - and y = 4[@@foo ] in - [%foo (((let module M = M in ()))[@foo ])]; - [%foo (((let open M in ()))[@foo ])]; - [%foo (((fun x -> ()))[@foo ])]; - [%foo (((function | x -> ()))[@foo ])]; - [%foo (((try () with | _ -> ()))[@foo ])]; - [%foo ((if () then () else ())[@foo ])]; - [%foo ((while () do () done)[@foo ])]; - [%foo ((for x = () to () do () done)[@foo ])]; - [%foo ((assert true)[@foo ])]; - [%foo ((lazy x)[@foo ])]; - [%foo ((object end)[@foo ])]; - [%foo ((3)[@foo ])]; - [%foo ((new x)[@foo ])]; - [%foo - (((match () with - | [%foo ? (((lazy x))[@foo ])] -> () - | [%foo ? ((exception x)[@foo ])] -> ())) - [@foo ])]] -class x = ((fun x -> let x = 3[@@foo ] in - ((object - inherit x[@@foo ] - val x = 3[@@foo ] - val virtual x : t[@@foo ] - val! mutable x = 3[@@foo ] - method x = 3[@@foo ] - method virtual x : t[@@foo ] - method! private x = 3[@@foo ] - initializer x[@@foo ] - end)[@foo ]))[@foo ]) -class type t = - object - inherit t[@@foo ] - val x : t[@@foo ] - val mutable x : t[@@foo ] - method x : t[@@foo ] - method private x : t[@@foo ] - constraint t = t'[@@foo ] - [@@@abc ] - [%%id ] - [@@@aaa ] - end[@foo ] -type t = [%foo : (((module M))[@foo ])] -module M = ((functor (M : S) -> ((((val - x))[@foo ]))(((struct end)[@foo ])))[@foo ]) -module type S = - ((functor (M : S) -> ((module type of M)[@foo ]) -> ((sig end)[@foo ])) - [@foo ]) -module type S = S -> S -> S -module type S = (S -> S) -> S -module type S = functor (M : S) -> S -> S -module type S = (functor (M : S) -> S) -> S -module type S = ((S -> S)[@foo ]) -> S -module type S = ((functor (M : S) -> S)[@foo ]) -> S -module type S = - sig module rec A: (S with type t = t) and B: (S with type t = t) end -[%%foo let x = 4[@@foo ] - and y = x[@@foo ]] -[%%foo type t = int[@@foo ] - and t = int[@@foo ]] -[%%foo type t += - | T [@@foo ]] -type t += - | A = M.A[@a ] -type t += - | B = M.A[@b ] - | C = M.A[@c ][@@t ] -[%%foo class x = x[@@foo ]] -[%%foo class type x = x[@@foo ]] -[%%foo external x : _ = ""[@@foo ]] -[%%foo exception X [@foo ]] -exception A = M.A[@a ] -[%%foo module M = M[@@foo ]] -[%%foo module rec M:S = M[@@foo ] and M:S = M[@@foo ]] -[%%foo module type S = S[@@foo ]] -[%%foo include M[@@foo ]] -[%%foo open M[@@foo ]] -module type S = - sig - [%%foo : val x : t[@@foo ]] - [%%foo : external x : t = ""[@@foo ]] - [%%foo : type t = int[@@foo ] - and t' = int[@@foo ]] - [%%foo : type t += - | T [@@foo ]] - [%%foo : exception X [@foo ]] - [%%foo : module M : S[@@foo ]] - [%%foo : module rec M: S[@@foo ] and M: S[@@foo ]] - [%%foo : module M = M[@@foo ]] - [%%foo : module type S = S[@@foo ]] - [%%foo : include M[@@foo ]] - [%%foo : open M[@@foo ]] - [%%foo : class x : t[@@foo ]] - [%%foo : class type x = x[@@foo ]] - end -type t = .. -type t += - | A -;;[%extension_constructor A] -;;([%extension_constructor A] : extension_constructor) -module M = struct type extension_constructor = int end -open M -;;([%extension_constructor A] : extension_constructor) -type 'a class_name = .. constraint 'a = < cast: 'a . 'a name -> 'a ;.. > -and 'a name = - | Class: 'a class_name -> (< cast: 'a . 'a name -> 'a ;.. > as 'a) name -exception Bad_cast -class type castable = object method cast : 'a . 'a name -> 'a end -class type foo_t = object inherit castable method foo : string end -type 'a class_name += - | Foo: foo_t class_name -class foo : foo_t = - object (self) - method cast : 'a . 'a name -> 'a= - fun (type a) -> - (function - | Class (Foo) -> (self :> foo_t) - | _ -> (raise Bad_cast : a) : a name -> a) - method foo = "foo" - end -class type bar_t = object inherit foo method bar : string end -type 'a class_name += - | Bar: bar_t class_name -class bar : bar_t = - object (self) - inherit foo as super - method cast : 'a . 'a name -> 'a= - fun (type a) -> - (function - | Class (Bar) -> (self :> bar_t) - | other -> super#cast other : a name -> a) - method bar = "bar" - [@@@id ] - [%%id ] - end -let clist : castable list ref = ref [] -let push_castable (c : #castable) = clist := ((c :> castable) :: (!clist)) -let pop_castable () = - match !clist with | c::rest -> (clist := rest; c) | [] -> raise Not_found -;;push_castable (new foo) -;;push_castable (new bar) -;;push_castable (new foo) -let c1 : castable = pop_castable () -let c2 : castable = pop_castable () -let c3 : castable = pop_castable () -let f1 : foo = c1#cast (Class Foo) -let f2 : foo = c2#cast (Class Foo) -let f3 : foo = c3#cast (Class Foo) -let b1 : bar = c1#cast (Class Bar) -let b2 : bar = c2#cast (Class Bar) -let b3 : bar = c3#cast (Class Bar) -type foo = .. -type foo += - | A - | B of int -let is_a x = match x with | A -> true | _ -> false -type foo -type foo += - | A of int -type 'a foo = .. -type ('a,'b) foo += - | A of int -module type S = sig type foo type foo += - | A of float end -module type S = sig type foo = - | A of int type foo += - | B of float end -type foo = .. -module M = - struct - type foo += - | A of int - | B of string - type foo += - | C of int - | D of float - end -module type S = - sig - type foo += - | B of string - | C of int - type foo += - | D of float - type foo += - | A of int - end -module M_S : S = M -type 'a foo = .. -type _ foo += - | A: int -> int foo - | B: int foo -let get_num : type a. a foo -> a -> a option = - fun f i1 -> match f with | A i2 -> Some (i1 + i2) | _ -> None -type 'a foo = .. constraint 'a = [> `Var ] -type 'a foo += - | A of 'a -let a = A 9 -type 'a foo += - | B: int foo -type foo = .. -module M = struct type foo += - | A of int end -let a1 = M.A 10 -module type S = sig type foo += private - | A of int end -module M_S : S = M -let is_s x = match x with | M_S.A _ -> true | _ -> false -let a2 = M_S.A 20 -type foo = .. -module M = struct type foo += - | A1 of int end -type foo += - | A2 = M.A1 -type bar = .. -type bar += - | A3 = M.A1 -module M = struct type foo += private - | B1 of int end -type foo += private - | B2 = M.B1 -type foo += - | B3 = M.B1 -type foo += - | C = Unknown -module M : sig type foo type foo += - | A1 of int end = - struct type foo = .. - type foo += - | A1 of int end -type M.foo += - | A2 = M.A1 -type 'a foo = .. -type 'a foo1 = 'a foo = .. -type 'a foo2 = 'a foo = .. -type 'a foo1 += - | A of int - | B of 'a - | C: int foo1 -type 'a foo2 += - | D = A - | E = B - | F = C -type +'a foo = .. -type 'a foo += - | A of (int -> 'a) -type 'a foo += - | B of ('a -> int) -type _ foo += - | C: ('a -> int) -> 'a foo -type 'a bar = .. -type +'a bar += - | D of (int -> 'a) -module M : sig type exn += - | Foo of int * float - | Bar: 'a list -> exn end = - struct exception Bar: 'a list -> exn - exception Foo of int * float end -module M : - sig exception Bar: 'a list -> exn exception Foo of int * float end = - struct type exn += - | Foo of int * float - | Bar: 'a list -> exn end -exception Foo of int * float -exception Bar: 'a list -> exn -module M : sig type exn += - | Foo of int * float - | Bar: 'a list -> exn end = - struct exception Bar = Bar - exception Foo = Foo end -type foo = .. -type foo += - | Foo of int * int option - | Bar of int option -let x = ((Foo (3, (Some 4))), (Bar (Some 5))) -type foo += - | Foo of string -let y = x -exception Foo of int * int option -exception Bar of int option -let x = ((Foo (3, (Some 4))), (Bar (Some 5))) -type foo += - | Foo of string -let y = x -type foo = .. -type foo += - | Foo - | Bar of int -let extension_name e = Obj.extension_name (Obj.extension_constructor e) -let extension_id e = Obj.extension_id (Obj.extension_constructor e) -let n1 = extension_name Foo -let n2 = extension_name (Bar 1) -let t = (extension_id (Bar 2)) = (extension_id (Bar 3)) -let f = (extension_id (Bar 2)) = (extension_id Foo) -let is_foo x = (extension_id Foo) = (extension_id x) -type foo += - | Foo -let f = is_foo Foo -let _ = Obj.extension_constructor 7 -let _ = Obj.extension_constructor (object method m = 3 end) -module Msg : - sig - type 'a tag - type result = - | Result: 'a tag * 'a -> result - val write : 'a tag -> 'a -> unit - val read : unit -> result - type 'a tag += - | Int: int tag - module type Desc = - sig - type t - val label : string - val write : t -> string - val read : string -> t - end - module Define : - functor (D : Desc) -> sig type 'a tag += - | C: D.t tag end - end = - struct - type 'a tag = .. - type ktag = - | T: 'a tag -> ktag - type 'a kind = - { - tag: 'a tag ; - label: string ; - write: 'a -> string ; - read: string -> 'a } - type rkind = - | K: 'a kind -> rkind - type wkind = { - f: 'a . 'a tag -> 'a kind } - let readTbl : (string, rkind) Hashtbl.t = Hashtbl.create 13 - let writeTbl : (ktag, wkind) Hashtbl.t = Hashtbl.create 13 - let read_raw () : (string * string)= raise (Failure "Not implemented") - type result = - | Result: 'a tag * 'a -> result - let read () = - let (label, content) = read_raw () in - let K k = Hashtbl.find readTbl label in - let body = k.read content in Result ((k.tag), body) - let write_raw (label : string) (content : string) = - raise (Failure "Not implemented") - let write (tag : 'a tag) (body : 'a) = - let { f } = Hashtbl.find writeTbl (T tag) in - let k = f tag in - let content = k.write body in write_raw k.label content - type 'a tag += - | Int: int tag - let ik = - { tag = Int; label = "int"; write = Int.to_string; read = int_of_string - } - let () = Hashtbl.add readTbl "int" (K ik) - let () = - let f (type t) (i : t tag) : t kind= - match i with | Int -> ik | _ -> assert false in - Hashtbl.add writeTbl (T Int) { f } - module type Desc = - sig - type t - val label : string - val write : t -> string - val read : string -> t - end - module Define(D:Desc) = - struct - type 'a tag += - | C: D.t tag - let k = { tag = C; label = D.label; write = D.write; read = D.read } - let () = Hashtbl.add readTbl D.label (K k) - let () = - let f (type t) (c : t tag) : t kind= - match c with | C -> k | _ -> assert false in - Hashtbl.add writeTbl (T C) { f } - end - end -let write_int i = Msg.write Msg.Int i -module StrM = - (Msg.Define)(struct - type t = string - let label = "string" - let read s = s - let write s = s - end) -type 'a Msg.tag += - | String = StrM.C -let write_string s = Msg.write String s -let read_one () = - let Msg.Result (tag, body) = Msg.read () in - match tag with - | Msg.Int -> print_int body - | String -> print_string body - | _ -> print_string "Unknown" -let sort (type s) set l = - let module Set = (val (set : (module Set.S with type elt = s))) in - Set.elements (List.fold_right Set.add l Set.empty) -let make_set (type s) cmp = - let module S = (Set.Make)(struct type t = s - let compare = cmp end) in ((module - S) : (module Set.S with type elt = s)) -let both l = - List.map (fun set -> sort set l) - [make_set compare; make_set (fun x y -> compare y x)] -let () = - print_endline - (String.concat " " - (List.map (String.concat "/") (both ["abc"; "xyz"; "def"]))) -module type S = - sig type t val to_string : t -> string val apply : t -> t val x : t end -let create (type s) to_string apply x = - let module M = - struct type t = s - let to_string = to_string - let apply = apply - let x = x end in ((module M) : (module S with type t = s)) -let forget (type s) x = - let module M = (val (x : (module S with type t = s))) in ((module - M) : (module S)) -let print x = - let module M = (val (x : (module S))) in print_endline (M.to_string M.x) -let apply x = - let module M = (val (x : (module S))) in - let module N = struct include M - let x = apply x end in ((module N) : (module S)) -let () = - let int = forget (create Int.to_string succ 0) in - let str = forget (create (fun s -> s) (fun s -> s ^ s) "X") in - List.iter print (List.map apply [int; apply int; apply (apply str)]) -module TypEq : - sig - type ('a, 'b) t - val apply : ('a, 'b) t -> 'a -> 'b - val refl : ('a, 'a) t - val sym : ('a, 'b) t -> ('b, 'a) t - end = - struct - type ('a, 'b) t = unit - let apply _ = Obj.magic - let refl = () - let sym () = () - end -module rec - Typ:sig - module type PAIR = - sig - type t - type t1 - type t2 - val eq : (t, (t1 * t2)) TypEq.t - val t1 : t1 Typ.typ - val t2 : t2 Typ.typ - end - type 'a typ = - | Int of ('a, int) TypEq.t - | String of ('a, string) TypEq.t - | Pair of (module PAIR with type t = 'a) - end = - struct - module type PAIR = - sig - type t - type t1 - type t2 - val eq : (t, (t1 * t2)) TypEq.t - val t1 : t1 Typ.typ - val t2 : t2 Typ.typ - end - type 'a typ = - | Int of ('a, int) TypEq.t - | String of ('a, string) TypEq.t - | Pair of (module PAIR with type t = 'a) - end - -open Typ -let int = Int TypEq.refl -let str = String TypEq.refl -let pair (type s1) (type s2) t1 t2 = - let module P = - struct - type t = (s1 * s2) - type t1 = s1 - type t2 = s2 - let eq = TypEq.refl - let t1 = t1 - let t2 = t2 - end in - let pair = ((module P) : (module PAIR with type t = (s1 * s2))) in - Pair pair -module rec Print:sig val to_string : 'a Typ.typ -> 'a -> string end = - struct - let to_string (type s) t x = - match t with - | Int eq -> Int.to_string (TypEq.apply eq x) - | String eq -> Printf.sprintf "%S" (TypEq.apply eq x) - | Pair p -> - let module P = (val (p : (module PAIR with type t = s))) in - let (x1, x2) = TypEq.apply P.eq x in - Printf.sprintf "(%s,%s)" (Print.to_string P.t1 x1) - (Print.to_string P.t2 x2) - end - -let () = - print_endline (Print.to_string int 10); - print_endline (Print.to_string (pair int (pair str int)) (123, ("A", 456))) -module type S1 = sig end -module type S2 = S1 -let _f (x : (module S1)) : (module S2)= x -module X = struct module type S end -module Y = struct include X end -let _f (x : (module X.S)) : (module Y.S)= x -module type S3 = sig val x : bool end -let f = - function - | Some ((module M) : (module S3)) when M.x -> 1 - | ((Some _)[@foooo ]) -> 2 - | None -> 3 -;;print_endline (Int.to_string (f (Some (module struct let x = false end)))) -type 'a ty = - | Int: int ty - | Bool: bool ty -let fbool (type t) (x : t) (tag : t ty) = match tag with | Bool -> x -let fint (type t) (x : t) (tag : t ty) = match tag with | Int -> x > 0 -let f (type t) (x : t) (tag : t ty) = - match tag with | Int -> x > 0 | Bool -> x -let g (type t) (x : t) (tag : t ty) = - match tag with | Bool -> x | Int -> x > 0 -let id x = x -let idb1 = (fun id -> let _ = id true in id) id -let idb2 : bool -> bool = id -let idb3 (_ : bool) = false -let g (type t) (x : t) (tag : t ty) = - match tag with | Bool -> idb3 x | Int -> x > 0 -let g (type t) (x : t) (tag : t ty) = - match tag with | Bool -> idb2 x | Int -> x > 0 -type 'a ty = - | Int: int ty - | String: string ty - | List: 'a ty -> 'a list ty - | Pair: ('a ty * 'b ty) -> ('a * 'b) ty -type variant = - | VInt of int - | VString of string - | VList of variant list - | VPair of variant * variant -let rec variantize : type t. t ty -> t -> variant = - fun ty x -> - match ty with - | Int -> VInt x - | String -> VString x - | List ty1 -> VList (List.map (variantize ty1) x) - | Pair (ty1, ty2) -> - VPair ((variantize ty1 (fst x)), (variantize ty2 (snd x))) -exception VariantMismatch -let rec devariantize : type t. t ty -> variant -> t = - fun ty v -> - match (ty, v) with - | (Int, VInt x) -> x - | (String, VString x) -> x - | (List ty1, VList vl) -> List.map (devariantize ty1) vl - | (Pair (ty1, ty2), VPair (x1, x2)) -> - ((devariantize ty1 x1), (devariantize ty2 x2)) - | _ -> raise VariantMismatch -type 'a ty = - | Int: int ty - | String: string ty - | List: 'a ty -> 'a list ty - | Pair: ('a ty * 'b ty) -> ('a * 'b) ty - | Record: 'a record -> 'a ty -and 'a record = { - path: string ; - fields: 'a field_ list } -and 'a field_ = - | Field: ('a, 'b) field -> 'a field_ -and ('a, 'b) field = { - label: string ; - field_type: 'b ty ; - get: 'a -> 'b } -type variant = - | VInt of int - | VString of string - | VList of variant list - | VPair of variant * variant - | VRecord of (string * variant) list -let rec variantize : type t. t ty -> t -> variant = - fun ty x -> - match ty with - | Int -> VInt x - | String -> VString x - | List ty1 -> VList (List.map (variantize ty1) x) - | Pair (ty1, ty2) -> - VPair ((variantize ty1 (fst x)), (variantize ty2 (snd x))) - | Record { fields } -> - VRecord - (List.map - (fun (Field { field_type; label; get }) -> - (label, (variantize field_type (get x)))) fields) -type 'a ty = - | Int: int ty - | String: string ty - | List: 'a ty -> 'a list ty - | Pair: ('a ty * 'b ty) -> ('a * 'b) ty - | Record: ('a, 'builder) record -> 'a ty -and ('a, 'builder) record = - { - path: string ; - fields: ('a, 'builder) field list ; - create_builder: unit -> 'builder ; - of_builder: 'builder -> 'a } -and ('a, 'builder) field = - | Field: ('a, 'builder, 'b) field_ -> ('a, 'builder) field -and ('a, 'builder, 'b) field_ = - { - label: string ; - field_type: 'b ty ; - get: 'a -> 'b ; - set: 'builder -> 'b -> unit } -let rec devariantize : type t. t ty -> variant -> t = - fun ty v -> - match (ty, v) with - | (Int, VInt x) -> x - | (String, VString x) -> x - | (List ty1, VList vl) -> List.map (devariantize ty1) vl - | (Pair (ty1, ty2), VPair (x1, x2)) -> - ((devariantize ty1 x1), (devariantize ty2 x2)) - | (Record { fields; create_builder; of_builder }, VRecord fl) -> - (if (List.length fields) <> (List.length fl) - then raise VariantMismatch; - (let builder = create_builder () in - List.iter2 - (fun (Field { label; field_type; set }) (lab, v) -> - if label <> lab then raise VariantMismatch; - set builder (devariantize field_type v)) fields fl; - of_builder builder)) - | _ -> raise VariantMismatch -type my_record = { - a: int ; - b: string list } -let my_record = - let fields = - [Field - { - label = "a"; - field_type = Int; - get = ((fun { a } -> a)); - set = ((fun (r, _) x -> r := (Some x))) - }; - Field - { - label = "b"; - field_type = (List String); - get = ((fun { b } -> b)); - set = ((fun (_, r) x -> r := (Some x))) - }] in - let create_builder () = ((ref None), (ref None)) in - let of_builder (a, b) = - match ((!a), (!b)) with - | (Some a, Some b) -> { a; b } - | _ -> failwith "Some fields are missing in record of type my_record" in - Record { path = "My_module.my_record"; fields; create_builder; of_builder } -type noarg = - | Noarg -type (_, _) ty = - | Int: (int, _) ty - | String: (string, _) ty - | List: ('a, 'e) ty -> ('a list, 'e) ty - | Option: ('a, 'e) ty -> ('a option, 'e) ty - | Pair: (('a, 'e) ty * ('b, 'e) ty) -> (('a * 'b), 'e) ty - | Var: ('a, 'a -> 'e) ty - | Rec: ('a, 'a -> 'e) ty -> ('a, 'e) ty - | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty - | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty - | Sum: ('a, 'e, 'b) ty_sum -> ('a, 'e) ty -and ('a, 'e, 'b) ty_sum = - { - sum_proj: 'a -> (string * 'e ty_dyn option) ; - sum_cases: (string * ('e, 'b) ty_case) list ; - sum_inj: 'c . (('b, 'c) ty_sel * 'c) -> 'a } -and 'e ty_dyn = - | Tdyn: ('a, 'e) ty * 'a -> 'e ty_dyn -and (_, _) ty_sel = - | Thd: ('a -> 'b, 'a) ty_sel - | Ttl: ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel -and (_, _) ty_case = - | TCarg: ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case - | TCnoarg: ('b, noarg) ty_sel -> ('e, 'b) ty_case -type _ ty_env = - | Enil: unit ty_env - | Econs: ('a, 'e) ty * 'e ty_env -> ('a -> 'e) ty_env -type (_, _) eq = - | Eq: ('a, 'a) eq -let rec eq_sel : type a b c. - (a, b) ty_sel -> (a, c) ty_sel -> (b, c) eq option = - fun s1 s2 -> - match (s1, s2) with - | (Thd, Thd) -> Some Eq - | (Ttl s1, Ttl s2) -> - (match eq_sel s1 s2 with | None -> None | Some (Eq) -> Some Eq) - | _ -> None -let rec get_case : type a b e. - (b, a) ty_sel -> - (string * (e, b) ty_case) list -> (string * (a, e) ty option) - = - fun sel cases -> - match cases with - | (name, TCnoarg sel')::rem -> - (match eq_sel sel sel' with - | None -> get_case sel rem - | Some (Eq) -> (name, None)) - | (name, TCarg (sel', ty))::rem -> - (match eq_sel sel sel' with - | None -> get_case sel rem - | Some (Eq) -> (name, (Some ty))) - | [] -> raise Not_found -type variant = - | VInt of int - | VString of string - | VList of variant list - | VOption of variant option - | VPair of variant * variant - | VConv of string * variant - | VSum of string * variant option -let may_map f = function | Some x -> Some (f x) | None -> None -let rec variantize : type a e. e ty_env -> (a, e) ty -> a -> variant = - fun e ty v -> - match ty with - | Int -> VInt v - | String -> VString v - | List t -> VList (List.map (variantize e t) v) - | Option t -> VOption (may_map (variantize e t) v) - | Pair (t1, t2) -> - VPair ((variantize e t1 (fst v)), (variantize e t2 (snd v))) - | Rec t -> variantize (Econs (ty, e)) t v - | Pop t -> (match e with | Econs (_, e') -> variantize e' t v) - | Var -> (match e with | Econs (t, e') -> variantize e' t v) - | Conv (s, proj, inj, t) -> VConv (s, (variantize e t (proj v))) - | Sum ops -> - let (tag, arg) = ops.sum_proj v in - VSum - (tag, - (may_map (function | Tdyn (ty, arg) -> variantize e ty arg) arg)) -let rec devariantize : type t e. e ty_env -> (t, e) ty -> variant -> t = - fun e ty v -> - match (ty, v) with - | (Int, VInt x) -> x - | (String, VString x) -> x - | (List ty1, VList vl) -> List.map (devariantize e ty1) vl - | (Pair (ty1, ty2), VPair (x1, x2)) -> - ((devariantize e ty1 x1), (devariantize e ty2 x2)) - | (Rec t, _) -> devariantize (Econs (ty, e)) t v - | (Pop t, _) -> (match e with | Econs (_, e') -> devariantize e' t v) - | (Var, _) -> (match e with | Econs (t, e') -> devariantize e' t v) - | (Conv (s, proj, inj, t), VConv (s', v)) when s = s' -> - inj (devariantize e t v) - | (Sum ops, VSum (tag, a)) -> - (try - match ((List.assoc tag ops.sum_cases), a) with - | (TCarg (sel, t), Some a) -> - ops.sum_inj (sel, (devariantize e t a)) - | (TCnoarg sel, None) -> ops.sum_inj (sel, Noarg) - | _ -> raise VariantMismatch - with | Not_found -> raise VariantMismatch) - | _ -> raise VariantMismatch -let wrap_A t = Conv ("`A", (fun (`A x) -> x), (fun x -> `A x), t) -let ty a = Rec (wrap_A (Option (Pair (a, Var)))) -let v = variantize Enil (ty Int) -let x = v (`A (Some (1, (`A (Some (2, (`A None))))))) -let triple t1 t2 t3 = - Conv - ("Triple", (fun (a, b, c) -> (a, (b, c))), - (fun (a, (b, c)) -> (a, b, c)), (Pair (t1, (Pair (t2, t3))))) -let v = variantize Enil (triple String Int Int) ("A", 2, 3) -let ty_abc = - let proj = - function - | `A n -> ("A", (Some (Tdyn (Int, n)))) - | `B s -> ("B", (Some (Tdyn (String, s)))) - | `C -> ("C", None) - and inj : type c. - ((int -> string -> noarg -> unit, c) ty_sel * c) -> - [ `A of int | `B of string | `C ] - = - function - | (Thd, v) -> `A v - | (Ttl (Thd), v) -> `B v - | (Ttl (Ttl (Thd)), Noarg) -> `C in - Sum - { - sum_proj = proj; - sum_inj = inj; - sum_cases = - [("A", (TCarg (Thd, Int))); - ("B", (TCarg ((Ttl Thd), String))); - ("C", (TCnoarg (Ttl (Ttl Thd))))] - } -let v = variantize Enil ty_abc (`A 3) -let a = devariantize Enil ty_abc v -type 'a vlist = [ `Nil | `Cons of ('a * 'a vlist) ] -let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = - fun t -> - let tcons = Pair ((Pop t), Var) in - Rec - (Sum - { - sum_proj = - ((function - | `Nil -> ("Nil", None) - | `Cons p -> ("Cons", (Some (Tdyn (tcons, p)))))); - sum_cases = - [("Nil", (TCnoarg Thd)); ("Cons", (TCarg ((Ttl Thd), tcons)))]; - sum_inj = - (fun (type c) -> - ((function | (Thd, Noarg) -> `Nil | (Ttl (Thd), v) -> `Cons v) : - ((noarg -> (a * a vlist) -> unit, c) ty_sel * c) -> a vlist)) - }) -let v = variantize Enil (ty_list Int) (`Cons (1, (`Cons (2, `Nil)))) -type (_, _) ty = - | Int: (int, _) ty - | String: (string, _) ty - | List: ('a, 'e) ty -> ('a list, 'e) ty - | Option: ('a, 'e) ty -> ('a option, 'e) ty - | Pair: (('a, 'e) ty * ('b, 'e) ty) -> (('a * 'b), 'e) ty - | Var: ('a, 'a -> 'e) ty - | Rec: ('a, 'a -> 'e) ty -> ('a, 'e) ty - | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty - | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty - | Sum: ('a -> (string * 'e ty_dyn option)) * - ((string * 'e ty_dyn option) -> 'a) -> ('a, 'e) ty -and 'e ty_dyn = - | Tdyn: ('a, 'e) ty * 'a -> 'e ty_dyn -let ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = - Sum - ((function - | `A n -> ("A", (Some (Tdyn (Int, n)))) - | `B s -> ("B", (Some (Tdyn (String, s)))) - | `C -> ("C", None)), - (function - | ("A", Some (Tdyn (Int, n))) -> `A n - | ("B", Some (Tdyn (String, s))) -> `B s - | ("C", None) -> `C - | _ -> invalid_arg "ty_abc")) -let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = - fun t -> - let targ = Pair ((Pop t), Var) in - Rec - (Sum - (((function - | `Nil -> ("Nil", None) - | `Cons p -> ("Cons", (Some (Tdyn (targ, p)))))), - ((function - | ("Nil", None) -> `Nil - | ("Cons", Some (Tdyn (Pair (_, Var), (p : (a * a vlist))))) -> - `Cons p)))) -type (_, _) ty = - | Int: (int, _) ty - | String: (string, _) ty - | List: ('a, 'e) ty -> ('a list, 'e) ty - | Option: ('a, 'e) ty -> ('a option, 'e) ty - | Pair: (('a, 'e) ty * ('b, 'e) ty) -> (('a * 'b), 'e) ty - | Var: ('a, 'a -> 'e) ty - | Rec: ('a, 'a -> 'e) ty -> ('a, 'e) ty - | Pop: ('a, 'e) ty -> ('a, 'b -> 'e) ty - | Conv: string * ('a -> 'b) * ('b -> 'a) * ('b, 'e) ty -> ('a, 'e) ty - | Sum: - < - proj: 'a -> (string * 'e ty_dyn option) ;cases: (string * ('e, 'b) - ty_case) list ; - inj: 'c . (('b, 'c) ty_sel * 'c) -> 'a > - -> ('a, 'e) ty -and 'e ty_dyn = - | Tdyn: ('a, 'e) ty * 'a -> 'e ty_dyn -and (_, _) ty_sel = - | Thd: ('a -> 'b, 'a) ty_sel - | Ttl: ('b -> 'c, 'd) ty_sel -> ('a -> 'b -> 'c, 'd) ty_sel -and (_, _) ty_case = - | TCarg: ('b, 'a) ty_sel * ('a, 'e) ty -> ('e, 'b) ty_case - | TCnoarg: ('b, noarg) ty_sel -> ('e, 'b) ty_case -let ty_abc : ([ `A of int | `B of string | `C ] as 'a, 'e) ty = - Sum - (object - method proj = - function - | `A n -> ("A", (Some (Tdyn (Int, n)))) - | `B s -> ("B", (Some (Tdyn (String, s)))) - | `C -> ("C", None) - method cases = - [("A", (TCarg (Thd, Int))); - ("B", (TCarg ((Ttl Thd), String))); - ("C", (TCnoarg (Ttl (Ttl Thd))))] - method inj : - 'c . - ((int -> string -> noarg -> unit, 'c) ty_sel * 'c) -> - [ `A of int | `B of string | `C ]= - fun (type c) -> - (function - | (Thd, v) -> `A v - | (Ttl (Thd), v) -> `B v - | (Ttl (Ttl (Thd)), Noarg) -> `C : ((int -> - string -> noarg -> unit, - c) ty_sel * c) -> - [ `A of int | `B of string - | `C ]) - end) -type 'a vlist = [ `Nil | `Cons of ('a * 'a vlist) ] -let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = - fun t -> - let tcons = Pair ((Pop t), Var) in - Rec - (Sum - (object - method proj = - function - | `Nil -> ("Nil", None) - | `Cons p -> ("Cons", (Some (Tdyn (tcons, p)))) - method cases = - [("Nil", (TCnoarg Thd)); ("Cons", (TCarg ((Ttl Thd), tcons)))] - method inj : - 'c . - ((noarg -> (a * a vlist) -> unit, 'c) ty_sel * 'c) -> a vlist= - fun (type c) -> - ((function | (Thd, Noarg) -> `Nil | (Ttl (Thd), v) -> `Cons v) : - ((noarg -> (a * a vlist) -> unit, c) ty_sel * c) -> a vlist) - end)) -type ('a, 'b) sum = - | Inl of 'a - | Inr of 'b -type zero = - | Zero -type 'a succ = - | Succ of 'a -type _ nat = - | NZ: zero nat - | NS: 'a nat -> 'a succ nat -type (_, _) seq = - | Snil: ('a, zero) seq - | Scons: 'a * ('a, 'n) seq -> ('a, 'n succ) seq -let l1 = Scons (3, (Scons (5, Snil))) -type (_, _, _) plus = - | PlusZ: 'a nat -> (zero, 'a, 'a) plus - | PlusS: ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus -let rec length : type a n. (a, n) seq -> n nat = - function | Snil -> NZ | Scons (_, s) -> NS (length s) -type (_, _, _) app = - | App: ('a, 'p) seq * ('n, 'm, 'p) plus -> ('a, 'n, 'm) app -let rec app : type a n m. (a, n) seq -> (a, m) seq -> (a, n, m) app = - fun xs ys -> - match xs with - | Snil -> App (ys, (PlusZ (length ys))) - | Scons (x, xs') -> - let App (xs'', pl) = app xs' ys in - App ((Scons (x, xs'')), (PlusS pl)) -type tp = - | TP -type nd = - | ND -type ('a, 'b) fk = - | FK -type _ shape = - | Tp: tp shape - | Nd: nd shape - | Fk: 'a shape * 'b shape -> ('a, 'b) fk shape -type tt = - | TT -type ff = - | FF -type _ boolean = - | BT: tt boolean - | BF: ff boolean -type (_, _) path = - | Pnone: 'a -> (tp, 'a) path - | Phere: (nd, 'a) path - | Pleft: ('x, 'a) path -> (('x, 'y) fk, 'a) path - | Pright: ('y, 'a) path -> (('x, 'y) fk, 'a) path -type (_, _) tree = - | Ttip: (tp, 'a) tree - | Tnode: 'a -> (nd, 'a) tree - | Tfork: ('x, 'a) tree * ('y, 'a) tree -> (('x, 'y) fk, 'a) tree -let tree1 = Tfork ((Tfork (Ttip, (Tnode 4))), (Tfork ((Tnode 4), (Tnode 3)))) -let rec find : type sh. - ('a -> 'a -> bool) -> 'a -> (sh, 'a) tree -> (sh, 'a) path list = - fun eq n t -> - match t with - | Ttip -> [] - | Tnode m -> if eq n m then [Phere] else [] - | Tfork (x, y) -> - (List.map (fun x -> Pleft x) (find eq n x)) @ - (List.map (fun x -> Pright x) (find eq n y)) -let rec extract : type sh. (sh, 'a) path -> (sh, 'a) tree -> 'a = - fun p t -> - match (p, t) with - | (Pnone x, Ttip) -> x - | (Phere, Tnode y) -> y - | (Pleft p, Tfork (l, _)) -> extract p l - | (Pright p, Tfork (_, r)) -> extract p r -type (_, _) le = - | LeZ: 'a nat -> (zero, 'a) le - | LeS: ('n, 'm) le -> ('n succ, 'm succ) le -type _ even = - | EvenZ: zero even - | EvenSS: 'n even -> 'n succ succ even -type one = zero succ -type two = one succ -type three = two succ -type four = three succ -let even0 : zero even = EvenZ -let even2 : two even = EvenSS EvenZ -let even4 : four even = EvenSS (EvenSS EvenZ) -let p1 : (two, one, three) plus = PlusS (PlusS (PlusZ (NS NZ))) -let rec summandLessThanSum : type a b c. (a, b, c) plus -> (a, c) le = - fun p -> - match p with | PlusZ n -> LeZ n | PlusS p' -> LeS (summandLessThanSum p') -type (_, _) equal = - | Eq: ('a, 'a) equal -let convert : type a b. (a, b) equal -> a -> b = fun (Eq) x -> x -let rec sameNat : type a b. a nat -> b nat -> (a, b) equal option = - fun a b -> - match (a, b) with - | (NZ, NZ) -> Some Eq - | (NS a', NS b') -> - (match sameNat a' b' with | Some (Eq) -> Some Eq | None -> None) - | _ -> None -let rec plus_func : type a b m n. - (a, b, m) plus -> (a, b, n) plus -> (m, n) equal = - fun p1 p2 -> - match (p1, p2) with - | (PlusZ _, PlusZ _) -> Eq - | (PlusS p1', PlusS p2') -> let Eq = plus_func p1' p2' in Eq -let rec plus_assoc : type a b c ab bc m n. - (a, b, ab) plus -> - (ab, c, m) plus -> (b, c, bc) plus -> (a, bc, n) plus -> (m, n) equal - = - fun p1 p2 p3 p4 -> - match (p1, p4) with - | (PlusZ b, PlusZ bc) -> let Eq = plus_func p2 p3 in Eq - | (PlusS p1', PlusS p4') -> - let PlusS p2' = p2 in let Eq = plus_assoc p1' p2' p3 p4' in Eq -let smaller : type a b. (a succ, b succ) le -> (a, b) le = - function | LeS x -> x -type (_, _) diff = - | Diff: 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff -let rec diff : type a b. (a, b) le -> a nat -> b nat -> (a, b) diff = - fun le a b -> - match (le, a, b) with - | (LeZ _, _, m) -> Diff (m, (PlusZ m)) - | (LeS q, NS x, NS y) -> - (match diff q x y with | Diff (m, p) -> Diff (m, (PlusS p))) -let rec diff : type a b. (a, b) le -> a nat -> b nat -> (a, b) diff = - fun le a b -> - match (a, b, le) with - | (NZ, m, LeZ _) -> Diff (m, (PlusZ m)) - | (NS x, NS y, LeS q) -> - (match diff q x y with | Diff (m, p) -> Diff (m, (PlusS p))) - | _ -> . -let rec diff : type a b. (a, b) le -> b nat -> (a, b) diff = - fun le b -> - match (b, le) with - | (m, LeZ _) -> Diff (m, (PlusZ m)) - | (NS y, LeS q) -> - (match diff q y with | Diff (m, p) -> Diff (m, (PlusS p))) -type (_, _) filter = - | Filter: ('m, 'n) le * ('a, 'm) seq -> ('a, 'n) filter -let rec leS' : type m n. (m, n) le -> (m, n succ) le = - function | LeZ n -> LeZ (NS n) | LeS le -> LeS (leS' le) -let rec filter : type a n. (a -> bool) -> (a, n) seq -> (a, n) filter = - fun f s -> - match s with - | Snil -> Filter ((LeZ NZ), Snil) - | Scons (a, l) -> - (match filter f l with - | Filter (le, l') -> - if f a - then Filter ((LeS le), (Scons (a, l'))) - else Filter ((leS' le), l')) -type (_, _, _) balance = - | Less: ('h, 'h succ, 'h succ) balance - | Same: ('h, 'h, 'h) balance - | More: ('h succ, 'h, 'h succ) balance -type _ avl = - | Leaf: zero avl - | Node: ('hL, 'hR, 'hMax) balance * 'hL avl * int * 'hR avl -> 'hMax succ - avl -type avl' = - | Avl: 'h avl -> avl' -let empty = Avl Leaf -let rec elem : type h. int -> h avl -> bool = - fun x t -> - match t with - | Leaf -> false - | Node (_, l, y, r) -> (x = y) || (if x < y then elem x l else elem x r) -let rec rotr : type n. - n succ succ avl -> - int -> n avl -> (n succ succ avl, n succ succ succ avl) sum - = - fun tL y tR -> - match tL with - | Node (Same, a, x, b) -> - Inr (Node (Less, a, x, (Node (More, b, y, tR)))) - | Node (More, a, x, b) -> - Inl (Node (Same, a, x, (Node (Same, b, y, tR)))) - | Node (Less, a, x, Node (Same, b, z, c)) -> - Inl (Node (Same, (Node (Same, a, x, b)), z, (Node (Same, c, y, tR)))) - | Node (Less, a, x, Node (Less, b, z, c)) -> - Inl (Node (Same, (Node (More, a, x, b)), z, (Node (Same, c, y, tR)))) - | Node (Less, a, x, Node (More, b, z, c)) -> - Inl (Node (Same, (Node (Same, a, x, b)), z, (Node (Less, c, y, tR)))) -let rec rotl : type n. - n avl -> - int -> n succ succ avl -> (n succ succ avl, n succ succ succ avl) sum - = - fun tL u tR -> - match tR with - | Node (Same, a, x, b) -> - Inr (Node (More, (Node (Less, tL, u, a)), x, b)) - | Node (Less, a, x, b) -> - Inl (Node (Same, (Node (Same, tL, u, a)), x, b)) - | Node (More, Node (Same, a, x, b), y, c) -> - Inl (Node (Same, (Node (Same, tL, u, a)), x, (Node (Same, b, y, c)))) - | Node (More, Node (Less, a, x, b), y, c) -> - Inl (Node (Same, (Node (More, tL, u, a)), x, (Node (Same, b, y, c)))) - | Node (More, Node (More, a, x, b), y, c) -> - Inl (Node (Same, (Node (Same, tL, u, a)), x, (Node (Less, b, y, c)))) -let rec ins : type n. int -> n avl -> (n avl, n succ avl) sum = - fun x t -> - match t with - | Leaf -> Inr (Node (Same, Leaf, x, Leaf)) - | Node (bal, a, y, b) -> - if x = y - then Inl t - else - if x < y - then - (match ins x a with - | Inl a -> Inl (Node (bal, a, y, b)) - | Inr a -> - (match bal with - | Less -> Inl (Node (Same, a, y, b)) - | Same -> Inr (Node (More, a, y, b)) - | More -> rotr a y b)) - else - (match ins x b with - | Inl b -> Inl (Node (bal, a, y, b) : n avl) - | Inr b -> - (match bal with - | More -> Inl (Node (Same, a, y, b) : n avl) - | Same -> Inr (Node (Less, a, y, b) : n succ avl) - | Less -> rotl a y b)) -let insert x (Avl t) = match ins x t with | Inl t -> Avl t | Inr t -> Avl t -let rec del_min : type n. n succ avl -> (int * (n avl, n succ avl) sum) = - function - | Node (Less, Leaf, x, r) -> (x, (Inl r)) - | Node (Same, Leaf, x, r) -> (x, (Inl r)) - | Node (bal, (Node _ as l), x, r) -> - (match del_min l with - | (y, Inr l) -> (y, (Inr (Node (bal, l, x, r)))) - | (y, Inl l) -> - (y, - ((match bal with - | Same -> Inr (Node (Less, l, x, r)) - | More -> Inl (Node (Same, l, x, r)) - | Less -> rotl l x r)))) -type _ avl_del = - | Dsame: 'n avl -> 'n avl_del - | Ddecr: ('m succ, 'n) equal * 'm avl -> 'n avl_del -let rec del : type n. int -> n avl -> n avl_del = - fun y t -> - match t with - | Leaf -> Dsame Leaf - | Node (bal, l, x, r) -> - if x = y - then - (match r with - | Leaf -> - (match bal with - | Same -> Ddecr (Eq, l) - | More -> Ddecr (Eq, l)) - | Node _ -> - (match (bal, (del_min r)) with - | (_, (z, Inr r)) -> Dsame (Node (bal, l, z, r)) - | (Same, (z, Inl r)) -> Dsame (Node (More, l, z, r)) - | (Less, (z, Inl r)) -> Ddecr (Eq, (Node (Same, l, z, r))) - | (More, (z, Inl r)) -> - (match rotr l z r with - | Inl t -> Ddecr (Eq, t) - | Inr t -> Dsame t))) - else - if y < x - then - (match del y l with - | Dsame l -> Dsame (Node (bal, l, x, r)) - | Ddecr (Eq, l) -> - (match bal with - | Same -> Dsame (Node (Less, l, x, r)) - | More -> Ddecr (Eq, (Node (Same, l, x, r))) - | Less -> - (match rotl l x r with - | Inl t -> Ddecr (Eq, t) - | Inr t -> Dsame t))) - else - (match del y r with - | Dsame r -> Dsame (Node (bal, l, x, r)) - | Ddecr (Eq, r) -> - (match bal with - | Same -> Dsame (Node (More, l, x, r)) - | Less -> Ddecr (Eq, (Node (Same, l, x, r))) - | More -> - (match rotr l x r with - | Inl t -> Ddecr (Eq, t) - | Inr t -> Dsame t))) -let delete x (Avl t) = - match del x t with | Dsame t -> Avl t | Ddecr (_, t) -> Avl t -type red = - | RED -type black = - | BLACK -type (_, _) sub_tree = - | Bleaf: (black, zero) sub_tree - | Rnode: (black, 'n) sub_tree * int * (black, 'n) sub_tree -> (red, - 'n) sub_tree - | Bnode: ('cL, 'n) sub_tree * int * ('cR, 'n) sub_tree -> (black, 'n succ) - sub_tree -type rb_tree = - | Root: (black, 'n) sub_tree -> rb_tree -type dir = - | LeftD - | RightD -type (_, _) ctxt = - | CNil: (black, 'n) ctxt - | CRed: int * dir * (black, 'n) sub_tree * (red, 'n) ctxt -> (black, - 'n) ctxt - | CBlk: int * dir * ('c1, 'n) sub_tree * (black, 'n succ) ctxt -> ( - 'c, 'n) ctxt -let blacken = function | Rnode (l, e, r) -> Bnode (l, e, r) -type _ crep = - | Red: red crep - | Black: black crep -let color : type c n. (c, n) sub_tree -> c crep = - function | Bleaf -> Black | Rnode _ -> Red | Bnode _ -> Black -let rec fill : type c n. (c, n) ctxt -> (c, n) sub_tree -> rb_tree = - fun ct t -> - match ct with - | CNil -> Root t - | CRed (e, LeftD, uncle, c) -> fill c (Rnode (uncle, e, t)) - | CRed (e, RightD, uncle, c) -> fill c (Rnode (t, e, uncle)) - | CBlk (e, LeftD, uncle, c) -> fill c (Bnode (uncle, e, t)) - | CBlk (e, RightD, uncle, c) -> fill c (Bnode (t, e, uncle)) -let recolor d1 pE sib d2 gE uncle t = - match (d1, d2) with - | (LeftD, RightD) -> Rnode ((Bnode (sib, pE, t)), gE, uncle) - | (RightD, RightD) -> Rnode ((Bnode (t, pE, sib)), gE, uncle) - | (LeftD, LeftD) -> Rnode (uncle, gE, (Bnode (sib, pE, t))) - | (RightD, LeftD) -> Rnode (uncle, gE, (Bnode (t, pE, sib))) -let rotate d1 pE sib d2 gE uncle (Rnode (x, e, y)) = - match (d1, d2) with - | (RightD, RightD) -> - Bnode ((Rnode (x, e, y)), pE, (Rnode (sib, gE, uncle))) - | (LeftD, RightD) -> - Bnode ((Rnode (sib, pE, x)), e, (Rnode (y, gE, uncle))) - | (LeftD, LeftD) -> Bnode ((Rnode (uncle, gE, sib)), pE, (Rnode (x, e, y))) - | (RightD, LeftD) -> - Bnode ((Rnode (uncle, gE, x)), e, (Rnode (y, pE, sib))) -let rec repair : type c n. (red, n) sub_tree -> (c, n) ctxt -> rb_tree = - fun t ct -> - match ct with - | CNil -> Root (blacken t) - | CBlk (e, LeftD, sib, c) -> fill c (Bnode (sib, e, t)) - | CBlk (e, RightD, sib, c) -> fill c (Bnode (t, e, sib)) - | CRed (e, dir, sib, CBlk (e', dir', uncle, ct)) -> - (match color uncle with - | Red -> repair (recolor dir e sib dir' e' (blacken uncle) t) ct - | Black -> fill ct (rotate dir e sib dir' e' uncle t)) -let rec ins : type c n. int -> (c, n) sub_tree -> (c, n) ctxt -> rb_tree = - fun e t ct -> - match t with - | Rnode (l, e', r) -> - if e < e' - then ins e l (CRed (e', RightD, r, ct)) - else ins e r (CRed (e', LeftD, l, ct)) - | Bnode (l, e', r) -> - if e < e' - then ins e l (CBlk (e', RightD, r, ct)) - else ins e r (CBlk (e', LeftD, l, ct)) - | Bleaf -> repair (Rnode (Bleaf, e, Bleaf)) ct -let insert e (Root t) = ins e t CNil -type _ term = - | Const: int -> int term - | Add: ((int * int) -> int) term - | LT: ((int * int) -> bool) term - | Ap: ('a -> 'b) term * 'a term -> 'b term - | Pair: 'a term * 'b term -> ('a * 'b) term -let ex1 = Ap (Add, (Pair ((Const 3), (Const 5)))) -let ex2 = Pair (ex1, (Const 1)) -let rec eval_term : type a. a term -> a = - function - | Const x -> x - | Add -> (fun (x, y) -> x + y) - | LT -> (fun (x, y) -> x < y) - | Ap (f, x) -> eval_term f (eval_term x) - | Pair (x, y) -> ((eval_term x), (eval_term y)) -type _ rep = - | Rint: int rep - | Rbool: bool rep - | Rpair: 'a rep * 'b rep -> ('a * 'b) rep - | Rfun: 'a rep * 'b rep -> ('a -> 'b) rep -type (_, _) equal = - | Eq: ('a, 'a) equal -let rec rep_equal : type a b. a rep -> b rep -> (a, b) equal option = - fun ra rb -> - match (ra, rb) with - | (Rint, Rint) -> Some Eq - | (Rbool, Rbool) -> Some Eq - | (Rpair (a1, a2), Rpair (b1, b2)) -> - (match rep_equal a1 b1 with - | None -> None - | Some (Eq) -> - (match rep_equal a2 b2 with - | None -> None - | Some (Eq) -> Some Eq)) - | (Rfun (a1, a2), Rfun (b1, b2)) -> - (match rep_equal a1 b1 with - | None -> None - | Some (Eq) -> - (match rep_equal a2 b2 with - | None -> None - | Some (Eq) -> Some Eq)) - | _ -> None -type assoc = - | Assoc: string * 'a rep * 'a -> assoc -let rec assoc : type a. string -> a rep -> assoc list -> a = - fun x r -> - function - | [] -> raise Not_found - | (Assoc (x', r', v))::env -> - if x = x' - then - (match rep_equal r r' with - | None -> failwith ("Wrong type for " ^ x) - | Some (Eq) -> v) - else assoc x r env -type _ term = - | Var: string * 'a rep -> 'a term - | Abs: string * 'a rep * 'b term -> ('a -> 'b) term - | Const: int -> int term - | Add: ((int * int) -> int) term - | LT: ((int * int) -> bool) term - | Ap: ('a -> 'b) term * 'a term -> 'b term - | Pair: 'a term * 'b term -> ('a * 'b) term -let rec eval_term : type a. assoc list -> a term -> a = - fun env -> - function - | Var (x, r) -> assoc x r env - | Abs (x, r, e) -> (fun v -> eval_term ((Assoc (x, r, v)) :: env) e) - | Const x -> x - | Add -> (fun (x, y) -> x + y) - | LT -> (fun (x, y) -> x < y) - | Ap (f, x) -> eval_term env f (eval_term env x) - | Pair (x, y) -> ((eval_term env x), (eval_term env y)) -let ex3 = - Abs ("x", Rint, (Ap (Add, (Pair ((Var ("x", Rint)), (Var ("x", Rint))))))) -let ex4 = Ap (ex3, (Const 3)) -let v4 = eval_term [] ex4 -type rnil = - | RNIL -type ('a, 'b, 'c) rcons = - | RCons of 'a * 'b * 'c -type _ is_row = - | Rnil: rnil is_row - | Rcons: 'c is_row -> ('a, 'b, 'c) rcons is_row -type (_, _) lam = - | Const: int -> ('e, int) lam - | Var: 'a -> (('a, 't, 'e) rcons, 't) lam - | Shift: ('e, 't) lam -> (('a, 'q, 'e) rcons, 't) lam - | Abs: 'a * (('a, 's, 'e) rcons, 't) lam -> ('e, 's -> 't) lam - | App: ('e, 's -> 't) lam * ('e, 's) lam -> ('e, 't) lam -type x = - | X -type y = - | Y -let ex1 = App ((Var X), (Shift (Var Y))) -let ex2 = Abs (X, (Abs (Y, (App ((Shift (Var X)), (Var Y)))))) -type _ env = - | Enil: rnil env - | Econs: 'a * 't * 'e env -> ('a, 't, 'e) rcons env -let rec eval_lam : type e t. e env -> (e, t) lam -> t = - fun env m -> - match (env, m) with - | (_, Const n) -> n - | (Econs (_, v, r), Var _) -> v - | (Econs (_, _, r), Shift e) -> eval_lam r e - | (_, Abs (n, body)) -> (fun x -> eval_lam (Econs (n, x, env)) body) - | (_, App (f, x)) -> eval_lam env f (eval_lam env x) -type add = - | Add -type suc = - | Suc -let env0 = Econs (Zero, 0, (Econs (Suc, succ, (Econs (Add, (+), Enil))))) -let _0 : (_, int) lam = Var Zero -let suc x = App ((Shift (Var Suc : (_, int -> int) lam)), x) -let _1 = suc _0 -let _2 = suc _1 -let _3 = suc _2 -let add = Shift (Shift (Var Add : (_, int -> int -> int) lam)) -let double = Abs (X, (App ((App ((Shift add), (Var X))), (Var X)))) -let ex3 = App (double, _3) -let v3 = eval_lam env0 ex3 -type _ rep = - | I: int rep - | Ar: 'a rep * 'b rep -> ('a -> 'b) rep -let rec compare : type a b. a rep -> b rep -> (string, (a, b) equal) sum = - fun a b -> - match (a, b) with - | (I, I) -> Inr Eq - | (Ar (x, y), Ar (s, t)) -> - (match compare x s with - | Inl _ as e -> e - | Inr (Eq) -> - (match compare y t with | Inl _ as e -> e | Inr (Eq) as e -> e)) - | (I, Ar _) -> Inl "I <> Ar _" - | (Ar _, I) -> Inl "Ar _ <> I" -type term = - | C of int - | Ab: string * 'a rep * term -> term - | Ap of term * term - | V of string -type _ ctx = - | Cnil: rnil ctx - | Ccons: 't * string * 'x rep * 'e ctx -> ('t, 'x, 'e) rcons ctx -type _ checked = - | Cerror of string - | Cok: ('e, 't) lam * 't rep -> 'e checked -let rec lookup : type e. string -> e ctx -> e checked = - fun name ctx -> - match ctx with - | Cnil -> Cerror ("Name not found: " ^ name) - | Ccons (l, s, t, rs) -> - if s = name - then Cok ((Var l), t) - else - (match lookup name rs with - | Cerror m -> Cerror m - | Cok (v, t) -> Cok ((Shift v), t)) -let rec tc : type n e. n nat -> e ctx -> term -> e checked = - fun n ctx t -> - match t with - | V s -> lookup s ctx - | Ap (f, x) -> - (match tc n ctx f with - | Cerror _ as e -> e - | Cok (f', ft) -> - (match tc n ctx x with - | Cerror _ as e -> e - | Cok (x', xt) -> - (match ft with - | Ar (a, b) -> - (match compare a xt with - | Inl s -> Cerror s - | Inr (Eq) -> Cok ((App (f', x')), b)) - | _ -> Cerror "Non fun in Ap"))) - | Ab (s, t, body) -> - (match tc (NS n) (Ccons (n, s, t, ctx)) body with - | Cerror _ as e -> e - | Cok (body', et) -> Cok ((Abs (n, body')), (Ar (t, et)))) - | C m -> Cok ((Const m), I) -let ctx0 = - Ccons - (Zero, "0", I, - (Ccons - (Suc, "S", (Ar (I, I)), - (Ccons (Add, "+", (Ar (I, (Ar (I, I)))), Cnil))))) -let ex1 = Ab ("x", I, (Ap ((Ap ((V "+"), (V "x"))), (V "x")))) -let c1 = tc NZ ctx0 ex1 -let ex2 = Ap (ex1, (C 3)) -let c2 = tc NZ ctx0 ex2 -let eval_checked env = - function - | Cerror s -> failwith s - | Cok (e, I) -> (eval_lam env e : int) - | Cok _ -> failwith "Can only evaluate expressions of type I" -let v2 = eval_checked env0 c2 -type pexp = - | PEXP -type pval = - | PVAL -type _ mode = - | Pexp: pexp mode - | Pval: pval mode -type ('a, 'b) tarr = - | TARR -type tint = - | TINT -type (_, _) rel = - | IntR: (tint, int) rel - | IntTo: ('b, 's) rel -> ((tint, 'b) tarr, int -> 's) rel -type (_, _, _) lam = - | Const: ('a, 'b) rel * 'b -> (pval, 'env, 'a) lam - | Var: 'a -> (pval, ('a, 't, 'e) rcons, 't) lam - | Shift: ('m, 'e, 't) lam -> ('m, ('a, 'q, 'e) rcons, 't) lam - | Lam: 'a * ('m, ('a, 's, 'e) rcons, 't) lam -> (pval, 'e, ('s, 't) tarr) - lam - | App: ('m1, 'e, ('s, 't) tarr) lam * ('m2, 'e, 's) lam -> (pexp, 'e, - 't) lam -let ex1 = App ((Lam (X, (Var X))), (Const (IntR, 3))) -let rec mode : type m e t. (m, e, t) lam -> m mode = - function - | Lam (v, body) -> Pval - | Var v -> Pval - | Const (r, v) -> Pval - | Shift e -> mode e - | App _ -> Pexp -type (_, _) sub = - | Id: ('r, 'r) sub - | Bind: 't * ('m, 'r2, 'x) lam * ('r, 'r2) sub -> (('t, 'x, 'r) rcons, - 'r2) sub - | Push: ('r1, 'r2) sub -> (('a, 'b, 'r1) rcons, ('a, 'b, 'r2) rcons) sub -type (_, _) lam' = - | Ex: ('m, 's, 't) lam -> ('s, 't) lam' -let rec subst : type m1 r t s. (m1, r, t) lam -> (r, s) sub -> (s, t) lam' = - fun t s -> - match (t, s) with - | (_, Id) -> Ex t - | (Const (r, c), sub) -> Ex (Const (r, c)) - | (Var v, Bind (x, e, r)) -> Ex e - | (Var v, Push sub) -> Ex (Var v) - | (Shift e, Bind (_, _, r)) -> subst e r - | (Shift e, Push sub) -> (match subst e sub with | Ex a -> Ex (Shift a)) - | (App (f, x), sub) -> - (match ((subst f sub), (subst x sub)) with - | (Ex g, Ex y) -> Ex (App (g, y))) - | (Lam (v, x), sub) -> - (match subst x (Push sub) with | Ex body -> Ex (Lam (v, body))) -type closed = rnil -type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum -let rec rule : type a b. - (pval, closed, (a, b) tarr) lam -> (pval, closed, a) lam -> b rlam = - fun v1 v2 -> - match (v1, v2) with - | (Lam (x, body), v) -> - (match subst body (Bind (x, v, Id)) with - | Ex term -> - (match mode term with | Pexp -> Inl term | Pval -> Inr term)) - | (Const (IntTo b, f), Const (IntR, x)) -> Inr (Const (b, (f x))) -let rec onestep : type m t. (m, closed, t) lam -> t rlam = - function - | Lam (v, body) -> Inr (Lam (v, body)) - | Const (r, v) -> Inr (Const (r, v)) - | App (e1, e2) -> - (match ((mode e1), (mode e2)) with - | (Pexp, _) -> - (match onestep e1 with - | Inl e -> Inl (App (e, e2)) - | Inr v -> Inl (App (v, e2))) - | (Pval, Pexp) -> - (match onestep e2 with - | Inl e -> Inl (App (e1, e)) - | Inr v -> Inl (App (e1, v))) - | (Pval, Pval) -> rule e1 e2) -type ('env, 'a) var = - | Zero: (('a * 'env), 'a) var - | Succ: ('env, 'a) var -> (('b * 'env), 'a) var -type ('env, 'a) typ = - | Tint: ('env, int) typ - | Tbool: ('env, bool) typ - | Tvar: ('env, 'a) var -> ('env, 'a) typ -let f : type env a. (env, a) typ -> (env, a) typ -> int = - fun ta tb -> - match (ta, tb) with - | (Tint, Tint) -> 0 - | (Tbool, Tbool) -> 1 - | (Tvar var, tb) -> 2 - | _ -> . -type inkind = [ `Link | `Nonlink ] -type _ inline_t = - | Text: string -> [< inkind> `Nonlink] inline_t - | Bold: 'a inline_t list -> 'a inline_t - | Link: string -> [< inkind> `Link] inline_t - | Mref: string * [ `Nonlink ] inline_t list -> [< inkind> `Link] inline_t -let uppercase seq = - let rec process : type a. a inline_t -> a inline_t = - function - | Text txt -> Text (String.uppercase_ascii txt) - | Bold xs -> Bold (List.map process xs) - | Link lnk -> Link lnk - | Mref (lnk, xs) -> Mref (lnk, (List.map process xs)) in - List.map process seq -type ast_t = - | Ast_Text of string - | Ast_Bold of ast_t list - | Ast_Link of string - | Ast_Mref of string * ast_t list -let inlineseq_from_astseq seq = - let rec process_nonlink = - function - | Ast_Text txt -> Text txt - | Ast_Bold xs -> Bold (List.map process_nonlink xs) - | _ -> assert false in - let rec process_any = - function - | Ast_Text txt -> Text txt - | Ast_Bold xs -> Bold (List.map process_any xs) - | Ast_Link lnk -> Link lnk - | Ast_Mref (lnk, xs) -> Mref (lnk, (List.map process_nonlink xs)) in - List.map process_any seq -type _ linkp = - | Nonlink: [ `Nonlink ] linkp - | Maylink: inkind linkp -let inlineseq_from_astseq seq = - let rec process : type a. a linkp -> ast_t -> a inline_t = - fun allow_link ast -> - match (allow_link, ast) with - | (Maylink, Ast_Text txt) -> Text txt - | (Nonlink, Ast_Text txt) -> Text txt - | (x, Ast_Bold xs) -> Bold (List.map (process x) xs) - | (Maylink, Ast_Link lnk) -> Link lnk - | (Nonlink, Ast_Link _) -> assert false - | (Maylink, Ast_Mref (lnk, xs)) -> - Mref (lnk, (List.map (process Nonlink) xs)) - | (Nonlink, Ast_Mref _) -> assert false in - List.map (process Maylink) seq -type _ linkp2 = - | Kind: 'a linkp -> ([< inkind] as 'a) linkp2 -let inlineseq_from_astseq seq = - let rec process : type a. a linkp2 -> ast_t -> a inline_t = - fun allow_link ast -> - match (allow_link, ast) with - | (Kind _, Ast_Text txt) -> Text txt - | (x, Ast_Bold xs) -> Bold (List.map (process x) xs) - | (Kind (Maylink), Ast_Link lnk) -> Link lnk - | (Kind (Nonlink), Ast_Link _) -> assert false - | (Kind (Maylink), Ast_Mref (lnk, xs)) -> - Mref (lnk, (List.map (process (Kind Nonlink)) xs)) - | (Kind (Nonlink), Ast_Mref _) -> assert false in - List.map (process (Kind Maylink)) seq -module Add(T:sig type two end) = - struct - type _ t = - | One: [ `One ] t - | Two: T.two t - let add (type a) : (a t * a t) -> string= - function | (One, One) -> "two" | (Two, Two) -> "four" - end -module B : - sig type (_, _) t = - | Eq: ('a, 'a) t val f : 'a -> 'b -> ('a, 'b) t end = - struct type (_, _) t = - | Eq: ('a, 'a) t - let f t1 t2 = Obj.magic Eq end -let of_type : type a. a -> a = fun x -> match B.f x 4 with | Eq -> 5 -type _ constant = - | Int: int -> int constant - | Bool: bool -> bool constant -type (_, _, _) binop = - | Eq: ('a, 'a, bool) binop - | Leq: ('a, 'a, bool) binop - | Add: (int, int, int) binop -let eval (type a) (type b) (type c) (bop : (a, b, c) binop) (x : a constant) - (y : b constant) : c constant= - match (bop, x, y) with - | (Eq, Bool x, Bool y) -> Bool (if x then y else not y) - | (Leq, Int x, Int y) -> Bool (x <= y) - | (Leq, Bool x, Bool y) -> Bool (x <= y) - | (Add, Int x, Int y) -> Int (x + y) -let _ = eval Eq (Int 2) (Int 3) -type tag = [ `TagA | `TagB | `TagC ] -type 'a poly = - | AandBTags: [< `TagA of int | `TagB ] poly - | ATag: [< `TagA of int ] poly -let intA = function | `TagA i -> i -let intB = function | `TagB -> 4 -let intAorB = function | `TagA i -> i | `TagB -> 4 -type _ wrapPoly = - | WrapPoly: 'a poly -> ([< `TagA of int | `TagB ] as 'a) wrapPoly -let example6 : type a. a wrapPoly -> (a -> int) = - fun w -> match w with | WrapPoly (ATag) -> intA | WrapPoly _ -> intA -let _ = example6 (WrapPoly AandBTags) `TagB -module F(S:sig type 'a t end) = - struct - type _ ab = - | A: int S.t ab - | B: float S.t ab - let f : int S.t ab -> float S.t ab -> string = - fun (l : int S.t ab) (r : float S.t ab) -> - match (l, r) with | (A, B) -> "f A B" - end -module F(S:sig type 'a t end) = - struct - type a = (int * int) - type b = int -> int - type _ ab = - | A: a S.t ab - | B: b S.t ab - let f : a S.t ab -> b S.t ab -> string = - fun l r -> match (l, r) with | (A, B) -> "f A B" - end -type (_, _) t = - | Any: ('a, 'b) t - | Eq: ('a, 'a) t -module M : sig type s = private [> `A ] val eq : (s, [ `A | `B ]) t end = - struct type s = [ `A | `B ] - let eq = Eq end -let f : (M.s, [ `A | `B ]) t -> string = function | Any -> "Any" -let () = print_endline (f M.eq) -module N : - sig - type s = private < a: int ;.. > - val eq : (s, < a: int ;b: bool > ) t - end = struct type s = < a: int ;b: bool > - let eq = Eq end -let f : (N.s, < a: int ;b: bool > ) t -> string = function | Any -> "Any" -type (_, _) comp = - | Eq: ('a, 'a) comp - | Diff: ('a, 'b) comp -module U = struct type t = - | T end -module M : sig type t = - | T val comp : (U.t, t) comp end = - struct include U - let comp = Eq end -;;match M.comp with | Diff -> false -module U = struct type t = { - x: int } end -module M : sig type t = { - x: int } val comp : (U.t, t) comp end = - struct include U - let comp = Eq end -;;match M.comp with | Diff -> false -type 'a t = - | T of 'a -type 'a s = - | S of 'a -type (_, _) eq = - | Refl: ('a, 'a) eq -let f : (int s, int t) eq -> unit = function | Refl -> () -module M(S:sig type 'a t = - | T of 'a type 'a s = - | T of 'a end) = - struct let f : ('a S.s, 'a S.t) eq -> unit = function | Refl -> () end -type _ nat = - | Zero: [ `Zero ] nat - | Succ: 'a nat -> [ `Succ of 'a ] nat -type 'a pre_nat = [ `Zero | `Succ of 'a ] -type aux = - | Aux: [ `Succ of [< [< [< [ `Zero ] pre_nat] pre_nat] pre_nat] ] nat -> - aux -let f (Aux x) = - match x with - | Succ (Zero) -> "1" - | Succ (Succ (Zero)) -> "2" - | Succ (Succ (Succ (Zero))) -> "3" - | Succ (Succ (Succ (Succ (Zero)))) -> "4" - | _ -> . -type _ t = - | C: ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t -let f : type a o. ((a -> o) -> o) t -> (a -> o) -> o = - fun (C) k -> k (fun x -> x) -type (_, _) t = - | A: ('a, 'a) t - | B: string -> ('a, 'b) t -module M(A:sig module type T end)(B:sig module type T end) = - struct - let f : ((module A.T), (module B.T)) t -> string = function | B s -> s - end -module A = struct module type T = sig end end -module N = ((M)(A))(A) -let x = N.f A -type 'a visit_action -type insert -type 'a local_visit_action -type ('a, 'result, 'visit_action) context = - | Local: ('a, ('a * insert) as 'result, 'a local_visit_action) context - | Global: ('a, 'a, 'a visit_action) context -let vexpr (type visit_action) : - (_, _, visit_action) context -> _ -> visit_action= - function | Local -> (fun _ -> raise Exit) | Global -> (fun _ -> raise Exit) -let vexpr (type visit_action) : - ('a, 'result, visit_action) context -> 'a -> visit_action= - function | Local -> (fun _ -> raise Exit) | Global -> (fun _ -> raise Exit) -let vexpr (type result) (type visit_action) : - (unit, result, visit_action) context -> unit -> visit_action= - function | Local -> (fun _ -> raise Exit) | Global -> (fun _ -> raise Exit) -module A = struct type nil = - | Cstr end -open A -type _ s = - | Nil: nil s - | Cons: 't s -> ('h -> 't) s -type ('stack, 'typ) var = - | Head: (('typ -> _) s, 'typ) var - | Tail: ('tail s, 'typ) var -> ((_ -> 'tail) s, 'typ) var -type _ lst = - | CNil: nil lst - | CCons: 'h * 't lst -> ('h -> 't) lst -let rec get_var : type stk ret. (stk s, ret) var -> stk lst -> ret = - fun n s -> - match (n, s) with - | (Head, CCons (h, _)) -> h - | (Tail n', CCons (_, t)) -> get_var n' t -type 'a t = [< `Foo | `Bar ] as 'a -type 'a s = [< `Foo | `Bar | `Baz > `Bar] as 'a -type 'a first = - | First: 'a second -> ('b t as 'a) first -and 'a second = - | Second: ('b s as 'a) second -type aux = - | Aux: 'a t second * ('a -> int) -> aux -let it : 'a . [< `Bar | `Foo > `Bar] as 'a = `Bar -let g (Aux (Second, f)) = f it -type (_, _) eqp = - | Y: ('a, 'a) eqp - | N: string -> ('a, 'b) eqp -let f : ('a list, 'a) eqp -> unit = function | N s -> print_string s -module rec A:sig type t = B.t list end = struct type t = B.t list end - and B:sig type t val eq : (B.t list, t) eqp end = - struct type t = A.t - let eq = Y end -;;f B.eq -type (_, _) t = - | Nil: ('tl, 'tl) t - | Cons: 'a * ('b, 'tl) t -> (('a * 'b), 'tl) t -let get1 (Cons (x, _) : ((_ * 'a), 'a) t) = x -let get1' = - function | (Cons (x, _) : ((_ * 'a), 'a) t) -> x | Nil -> assert false -type _ t = - | Int: int -> int t - | String: string -> string t - | Same: 'l t -> 'l t -let rec f = function | Int x -> x | Same s -> f s -type 'a tt = 'a t = - | Int: int -> int tt - | String: string -> string tt - | Same: 'l1 t -> 'l2 tt -type _ t = - | I: int t -let f (type a) (x : a t) = - let module M = struct let (I : a t) = x - let x = (I : a t) end in () -type (_, _) eq = - | Refl: ('a, 'a) eq -let bad (type a) = - let module N = - struct - module rec M:sig val e : (int, a) eq end = - struct let (Refl : (int, a) eq) = M.e - let e : (int, a) eq = Refl end - - end in N.M.e -type +'a n = private int -type nil = private - | Nil_type -type (_, _) elt = - | Elt_fine: 'nat n -> ('l, ('nat * 'l)) elt - | Elt: 'nat n -> ('l, 'nat -> 'l) elt -type _ t = - | Nil: nil t - | Cons: ('x, 'fx) elt * 'x t -> 'fx t -let undetected : ('a -> 'b -> nil) t -> 'a n -> 'b n -> unit = - fun sh i j -> let Cons (Elt dim, _) = sh in () -type _ t = - | T: int t -let _ = match (raise Not_found : float t) with | _ -> . -type (_, _) eq = - | Eq: ('a, 'a) eq - | Neq: int -> ('a, 'b) eq -type 'a t -let f (type a) (Neq n : (a, a t) eq) = n -module F(T:sig type _ t end) = - struct let f (type a) (Neq n : (a, a T.t) eq) = n end -type zero = - | Zero -type _ succ = - | Succ -type _ nat = - | NZ: zero nat - | NS: 'a nat -> 'a succ nat -type _ fin = - | FZ: 'a succ fin - | FS: 'a fin -> 'a succ fin -type _ is_succ = - | IS: 'a succ is_succ -let fin_succ : type n. n fin -> n is_succ = function | FZ -> IS | FS _ -> IS -type 'a term = - | Var of 'a fin - | Leaf - | Fork of 'a term * 'a term -let var x = Var x -let lift r : 'm fin -> 'n term= fun x -> Var (r x) -let rec pre_subst f = - function - | Var x -> f x - | Leaf -> Leaf - | Fork (t1, t2) -> Fork ((pre_subst f t1), (pre_subst f t2)) -let comp_subst f g (x : 'a fin) = pre_subst f (g x) -let rec thin : type n. n succ fin -> n fin -> n succ fin = - fun x y -> - match (x, y) with - | (FZ, y) -> FS y - | (FS x, FZ) -> FZ - | (FS x, FS y) -> FS (thin x y) -let bind t f = match t with | None -> None | Some x -> f x -let rec thick : type n. n succ fin -> n succ fin -> n fin option = - fun x y -> - match (x, y) with - | (FZ, FZ) -> None - | (FZ, FS y) -> Some y - | (FS x, FZ) -> let IS = fin_succ x in Some FZ - | (FS x, FS y) -> - let IS = fin_succ x in bind (thick x y) (fun x -> Some (FS x)) -let rec check : type n. n succ fin -> n succ term -> n term option = - fun x t -> - match t with - | Var y -> bind (thick x y) (fun x -> Some (Var x)) - | Leaf -> Some Leaf - | Fork (t1, t2) -> - bind (check x t1) - (fun t1 -> bind (check x t2) (fun t2 -> Some (Fork (t1, t2)))) -let subst_var x t' y = match thick x y with | None -> t' | Some y' -> Var y' -let subst x t' = pre_subst (subst_var x t') -type (_, _) alist = - | Anil: ('n, 'n) alist - | Asnoc: ('m, 'n) alist * 'm term * 'm succ fin -> ('m succ, 'n) alist -let rec sub : type m n. (m, n) alist -> m fin -> n term = - function - | Anil -> var - | Asnoc (s, t, x) -> comp_subst (sub s) (subst_var x t) -let rec append : type m n l. (m, n) alist -> (l, m) alist -> (l, n) alist = - fun r s -> - match s with | Anil -> r | Asnoc (s, t, x) -> Asnoc ((append r s), t, x) -type _ ealist = - | EAlist: ('a, 'b) alist -> 'a ealist -let asnoc a t' x = EAlist (Asnoc (a, t', x)) -let rec weaken_fin : type n. n fin -> n succ fin = - function | FZ -> FZ | FS x -> FS (weaken_fin x) -let weaken_term t = pre_subst (fun x -> Var (weaken_fin x)) t -let rec weaken_alist : type m n. (m, n) alist -> (m succ, n succ) alist = - function - | Anil -> Anil - | Asnoc (s, t, x) -> - Asnoc ((weaken_alist s), (weaken_term t), (weaken_fin x)) -let rec sub' : type m. m ealist -> m fin -> m term = - function - | EAlist (Anil) -> var - | EAlist (Asnoc (s, t, x)) -> - comp_subst (sub' (EAlist (weaken_alist s))) - (fun t' -> weaken_term (subst_var x t t')) -let subst' d = pre_subst (sub' d) -let flex_flex x y = - match thick x y with - | Some y' -> asnoc Anil (Var y') x - | None -> EAlist Anil -let flex_rigid x t = bind (check x t) (fun t' -> Some (asnoc Anil t' x)) -let rec amgu : type m. m term -> m term -> m ealist -> m ealist option = - fun s t acc -> - match (s, t, acc) with - | (Leaf, Leaf, _) -> Some acc - | (Leaf, Fork _, _) -> None - | (Fork _, Leaf, _) -> None - | (Fork (s1, s2), Fork (t1, t2), _) -> bind (amgu s1 t1 acc) (amgu s2 t2) - | (Var x, Var y, EAlist (Anil)) -> - let IS = fin_succ x in Some (flex_flex x y) - | (Var x, t, EAlist (Anil)) -> let IS = fin_succ x in flex_rigid x t - | (t, Var x, EAlist (Anil)) -> let IS = fin_succ x in flex_rigid x t - | (s, t, EAlist (Asnoc (d, r, z))) -> - bind (amgu (subst z r s) (subst z r t) (EAlist d)) - (fun (EAlist d) -> Some (asnoc d r z)) -let mgu s t = amgu s t (EAlist Anil) -let s = Fork ((Var FZ), (Fork ((Var (FS (FS FZ))), Leaf))) -let t = Fork ((Var (FS FZ)), (Var (FS FZ))) -let d = match mgu s t with | Some x -> x | None -> failwith "mgu" -let s' = subst' d s -let t' = subst' d t -type (_, _) eq = - | Refl: ('a, 'a) eq -let magic : 'a 'b . 'a -> 'b = - fun (type a) (type b) (x : a) -> - let module M = (functor (T : sig type 'a t end) -> - struct let f (Refl : (a T.t, b T.t) eq) = (x :> b) end)(struct - type - 'a t = - unit - end) in - M.f Refl -type (_, +_) eq = - | Refl: ('a, 'a) eq -let magic : 'a 'b . 'a -> 'b = - fun (type a) (type b) (x : a) -> - let bad_proof (type a) = - (Refl : (< m: a > , < m: a > ) eq :> (< m: a > , < > ) eq) in - let downcast : type a. (a, < > ) eq -> < > -> a = - fun (type a) (Refl : (a, < > ) eq) (s : < > ) -> (s :> a) in - (downcast bad_proof (object method m = x end :> < > ))#m -type _ t = - | IntLit: int t - | BoolLit: bool t -let check : type s. (s t * s) -> bool = - function | (BoolLit, false) -> false | (IntLit, 6) -> false -type ('a, 'b) pair = { - fst: 'a ; - snd: 'b } -let check : type s. (s t, s) pair -> bool = - function - | { fst = BoolLit; snd = false } -> false - | { fst = IntLit; snd = 6 } -> false -module type S = sig type t[@@immediate ] end -module F(M:S) : S = M -[%%expect - {| -module type S = sig type t [@@immediate] end -module F : functor (M : S) -> S -|}] -module A = - struct - type t[@@immediate ] - type s = t[@@immediate ] - type r = s - type p = q[@@immediate ] - and q = int - end -[%%expect - {| -module A : - sig - type t [@@immediate] - type s = t [@@immediate] - type r = s - type p = q [@@immediate] - and q = int - end -|}] -module type X = sig type t end -module Y = struct type t = int end -module Z : sig type t[@@immediate ] end = (Y : X with type t = int) -[%%expect - {| -module type X = sig type t end -module Y : sig type t = int end -module Z : sig type t [@@immediate] end -|}] -module M_valid : S = struct type t = int end -module FM_valid = (F)(struct type t = int end) -[%%expect {| -module M_valid : S -module FM_valid : S -|}] -module Foo : sig type t val x : t ref end = - struct type t = int - let x = ref 0 end -[%%expect {| -module Foo : sig type t val x : t ref end -|}] -module Bar : sig type t[@@immediate ] val x : t ref end = - struct type t = int - let x = ref 0 end -[%%expect {| -module Bar : sig type t [@@immediate] val x : t ref end -|}] -let test f = let start = Sys.time () in f (); (Sys.time ()) -. start -[%%expect {| -val test : (unit -> 'a) -> float = -|}] -let test_foo () = for i = 0 to 100_000_000 do Foo.x := (!Foo.x) done -[%%expect {| -val test_foo : unit -> unit = -|}] -let test_bar () = for i = 0 to 100_000_000 do Bar.x := (!Bar.x) done -[%%expect {| -val test_bar : unit -> unit = -|}] -module B = struct type t = string[@@immediate ] end -[%%expect - {| -Line _, characters 2-31: -Error: Types marked with the immediate attribute must be - non-pointer types like int or bool -|}] -module C = struct type t - type s = t[@@immediate ] end -[%%expect - {| -Line _, characters 2-26: -Error: Types marked with the immediate attribute must be - non-pointer types like int or bool -|}] -module D : sig type t[@@immediate ] end = struct type t = string end -[%%expect - {| -Line _, characters 42-70: -Error: Signature mismatch: - Modules do not match: - sig type t = string end - is not included in - sig type t [@@immediate] end - Type declarations do not match: - type t = string - is not included in - type t [@@immediate] - the first is not an immediate type. -|}] -module M_invalid : S = struct type t = string end -module FM_invalid = (F)(struct type t = string end) -[%%expect - {| -Line _, characters 23-49: -Error: Signature mismatch: - Modules do not match: sig type t = string end is not included in S - Type declarations do not match: - type t = string - is not included in - type t [@@immediate] - the first is not an immediate type. -|}] -module E = struct type t = s[@@immediate ] - and s = string end -[%%expect - {| -Line _, characters 2-26: -Error: Types marked with the immediate attribute must be - non-pointer types like int or bool -|}] -let sort (type s) ((module Set) : (module Set.S with type elt = s)) l = - Set.elements (List.fold_right Set.add l Set.empty) -let make_set (type s) cmp : (module Set.S with type elt = s)= (module - (Set.Make)(struct type t = s - let compare = cmp end)) -let sort_cmp (type s) cmp = - sort (module (Set.Make)(struct type t = s - let compare = cmp end)) -module type S = sig type t val x : t end -let f ((module M) : (module S with type t = int)) = M.x -let f ((module M) : (module S with type t = 'a)) = M.x -let f (type a) ((module M) : (module S with type t = a)) = M.x -;;f (module struct type t = int - let x = 1 end) -type 'a s = { - s: (module S with type t = 'a) } -;;{ s = (module struct type t = int - let x = 1 end) } -let f { s = (module M) } = M.x -let f (type a) ({ s = (module M) } : a s) = M.x -type s = { - s: (module S with type t = int) } -let f { s = (module M) } = M.x -let f { s = (module M) } { s = (module N) } = M.x + N.x -module type S = sig val x : int end -let f ((module M) : (module S)) y ((module N) : (module S)) = - (M.x + y) + N.x -let m = (module struct let x = 3 end) -let m = ((module struct let x = 3 end) : (module S)) -;;f m 1 m -;;f m 1 (module struct let x = 2 end) -;;let (module M) = m in M.x -let (module M) = m -class c = let (module M) = m in object end -module M = (val m) -module type S' = sig val f : int -> int end -;;let rec ((module M) : (module S')) = ((module - struct let f n = if n <= 0 then 1 else n * (M.f (n - 1)) end) : (module - S')) in - M.f 3 -module type S = sig type t type u val x : (t * u) end -let f (l : (module S with type t = int and type u = bool) list) = - (l :> (module S with type u = bool) list) -module TypEq : - sig - type ('a, 'b) t - val apply : ('a, 'b) t -> 'a -> 'b - val refl : ('a, 'a) t - val sym : ('a, 'b) t -> ('b, 'a) t - end = - struct - type ('a, 'b) t = (('a -> 'b) * ('b -> 'a)) - let refl = ((fun x -> x), (fun x -> x)) - let apply (f, _) x = f x - let sym (f, g) = (g, f) - end -module rec - Typ:sig - module type PAIR = - sig - type t - and t1 - and t2 - val eq : (t, (t1 * t2)) TypEq.t - val t1 : t1 Typ.typ - val t2 : t2 Typ.typ - end - type 'a typ = - | Int of ('a, int) TypEq.t - | String of ('a, string) TypEq.t - | Pair of (module PAIR with type t = 'a) - end = Typ - -let int = Typ.Int TypEq.refl -let str = Typ.String TypEq.refl -let pair (type s1) (type s2) t1 t2 = - let module P = - struct - type t = (s1 * s2) - type t1 = s1 - type t2 = s2 - let eq = TypEq.refl - let t1 = t1 - let t2 = t2 - end in Typ.Pair (module P) -open Typ -let rec to_string : 'a . 'a Typ.typ -> 'a -> string = - fun (type s) t x -> - match (t : s typ) with - | Int eq -> Int.to_string (TypEq.apply eq x) - | String eq -> Printf.sprintf "%S" (TypEq.apply eq x) - | Pair (module P) -> - let (x1, x2) = TypEq.apply P.eq x in - Printf.sprintf "(%s,%s)" (to_string P.t1 x1) (to_string P.t2 x2) -module type MapT = - sig - include Map.S - type data - type map - val of_t : data t -> map - val to_t : map -> data t - end -type ('k, 'd, 'm) map = - (module MapT with type key = 'k and type data = 'd and type map = 'm) -let add (type k) (type d) (type m) (m : (k, d, m) map) x y s = - let module M = (val - (m : (module MapT with type key = k and type data = d and type map = m))) - in M.of_t (M.add x y (M.to_t s)) -module SSMap = - struct - include (Map.Make)(String) - type data = string - type map = data t - let of_t x = x - let to_t x = x - end -let ssmap = ((module - SSMap) : (module MapT with type key = string and type data = string and - type map = SSMap.map)) -let ssmap = ((module - struct include SSMap end) : (module MapT with type key = string and - type data = string and type map = SSMap.map)) -let ssmap = - (let module S = struct include SSMap end in (module S) : (module MapT with - type key = - string and - type data = - string and - type map = - SSMap.map)) -let ssmap = ((module - SSMap) : (module MapT with type key = _ and type data = _ and type map = _)) -let ssmap : (_, _, _) map = (module SSMap) -;;add ssmap -open StdLabels -open MoreLabels -module Subst = (Map.Make)(struct type t = string - let compare = compare end) -module Names = (Set.Make)(struct type t = string - let compare = compare end) -type var = [ `Var of string ] -let subst_var ~subst : var -> _= - function | `Var s as x -> (try Subst.find s subst with | Not_found -> x) -let free_var : var -> _ = function | `Var s -> Names.singleton s -type 'a lambda = - [ `Var of string | `Abs of (string * 'a) | `App of ('a * 'a) ] -let free_lambda ~free_rec : _ lambda -> _= - function - | #var as x -> free_var x - | `Abs (s, t) -> Names.remove s (free_rec t) - | `App (t1, t2) -> Names.union (free_rec t1) (free_rec t2) -let map_lambda ~map_rec : _ lambda -> _= - function - | #var as x -> x - | `Abs (s, t) as l -> - let t' = map_rec t in if t == t' then l else `Abs (s, t') - | `App (t1, t2) as l -> - let t'1 = map_rec t1 - and t'2 = map_rec t2 in - if (t'1 == t1) && (t'2 == t2) then l else `App (t'1, t'2) -let next_id = let current = ref 3 in fun () -> incr current; !current -let subst_lambda ~subst_rec ~free ~subst : _ lambda -> _= - function - | #var as x -> subst_var ~subst x - | `Abs (s, t) as l -> - let used = free t in - let used_expr = - Subst.fold subst ~init:[] - ~f:(fun ~key ~data acc -> - if Names.mem s used then data :: acc else acc) in - if List.exists used_expr ~f:(fun t -> Names.mem s (free t)) - then - let name = s ^ (Int.to_string (next_id ())) in - `Abs - (name, - (subst_rec ~subst:(Subst.add ~key:s ~data:(`Var name) subst) t)) - else map_lambda ~map_rec:(subst_rec ~subst:(Subst.remove s subst)) l - | `App _ as l -> map_lambda ~map_rec:(subst_rec ~subst) l -let eval_lambda ~eval_rec ~subst l = - match map_lambda ~map_rec:eval_rec l with - | `App (`Abs (s, t1), t2) -> - eval_rec (subst ~subst:(Subst.add ~key:s ~data:t2 Subst.empty) t1) - | t -> t -let rec free1 x = free_lambda ~free_rec:free1 x -let rec subst1 ~subst = subst_lambda ~subst_rec:subst1 ~free:free1 ~subst -let rec eval1 x = eval_lambda ~eval_rec:eval1 ~subst:subst1 x -type 'a expr = - [ `Var of string | `Num of int | `Add of ('a * 'a) | `Neg of 'a - | `Mult of ('a * 'a) ] -let free_expr ~free_rec : _ expr -> _= - function - | #var as x -> free_var x - | `Num _ -> Names.empty - | `Add (x, y) -> Names.union (free_rec x) (free_rec y) - | `Neg x -> free_rec x - | `Mult (x, y) -> Names.union (free_rec x) (free_rec y) -let map_expr ~map_rec : _ expr -> _= - function - | #var as x -> x - | `Num _ as x -> x - | `Add (x, y) as e -> - let x' = map_rec x - and y' = map_rec y in - if (x == x') && (y == y') then e else `Add (x', y') - | `Neg x as e -> let x' = map_rec x in if x == x' then e else `Neg x' - | `Mult (x, y) as e -> - let x' = map_rec x - and y' = map_rec y in - if (x == x') && (y == y') then e else `Mult (x', y') -let subst_expr ~subst_rec ~subst : _ expr -> _= - function - | #var as x -> subst_var ~subst x - | #expr as e -> map_expr ~map_rec:(subst_rec ~subst) e -let eval_expr ~eval_rec e = - match map_expr ~map_rec:eval_rec e with - | `Add (`Num m, `Num n) -> `Num (m + n) - | `Neg (`Num n) -> `Num (- n) - | `Mult (`Num m, `Num n) -> `Num (m * n) - | #expr as e -> e -let rec free2 x = free_expr ~free_rec:free2 x -let rec subst2 ~subst = subst_expr ~subst_rec:subst2 ~subst -let rec eval2 x = eval_expr ~eval_rec:eval2 x -type lexpr = - [ `Var of string | `Abs of (string * lexpr) | `App of (lexpr * lexpr) - | `Num of int | `Add of (lexpr * lexpr) | `Neg of lexpr - | `Mult of (lexpr * lexpr) ] -let rec free : lexpr -> _ = - function - | #lambda as x -> free_lambda ~free_rec:free x - | #expr as x -> free_expr ~free_rec:free x -let rec subst ~subst:s : lexpr -> _= - function - | #lambda as x -> subst_lambda ~subst_rec:subst ~subst:s ~free x - | #expr as x -> subst_expr ~subst_rec:subst ~subst:s x -let rec eval : lexpr -> _ = - function - | #lambda as x -> eval_lambda ~eval_rec:eval ~subst x - | #expr as x -> eval_expr ~eval_rec:eval x -let rec print = - function - | `Var id -> print_string id - | `Abs (id, l) -> (print_string (" " ^ (id ^ " . ")); print l) - | `App (l1, l2) -> (print l1; print_string " "; print l2) - | `Num x -> print_int x - | `Add (e1, e2) -> (print e1; print_string " + "; print e2) - | `Neg e -> (print_string "-"; print e) - | `Mult (e1, e2) -> (print e1; print_string " * "; print e2) -let () = - let e1 = eval1 (`App ((`Abs ("x", (`Var "x"))), (`Var "y"))) in - let e2 = eval2 (`Add ((`Mult ((`Num 3), (`Neg (`Num 2)))), (`Var "x"))) in - let e3 = - eval - (`Add - ((`App ((`Abs ("x", (`Mult ((`Var "x"), (`Var "x"))))), (`Num 2))), - (`Num 5))) in - print e1; - print_newline (); - print e2; - print_newline (); - print e3; - print_newline () -open StdLabels -open MoreLabels -module Subst = (Map.Make)(struct type t = string - let compare = compare end) -module Names = (Set.Make)(struct type t = string - let compare = compare end) -let lazy_fix make = - let rec obj () = make (lazy (obj ()) : _ Lazy.t) in obj () -let (!!) = Lazy.force -class type ['a,'b] ops = - object - method free : x:'b -> ?y:'c -> Names.t - method subst : sub:'a Subst.t -> 'b -> 'a - method eval : 'b -> 'a - end -type var = [ `Var of string ] -class ['a] var_ops = - object (self : ('a,var) #ops) - constraint 'a = [> var] - method subst ~sub (`Var s as x) = - try Subst.find s sub with | Not_found -> x - method free (`Var s) = Names.singleton s - method eval (#var as v) = v - end -type 'a lambda = - [ `Var of string | `Abs of (string * 'a) | `App of ('a * 'a) ] -let next_id = let current = ref 3 in fun () -> incr current; !current -class ['a] lambda_ops (ops : ('a,'a) #ops Lazy.t)= - let var : 'a var_ops = new var_ops - and free = lazy ((!! ops)#free) - and subst = lazy ((!! ops)#subst) - and eval = lazy ((!! ops)#eval) in - object (self : ('a,'a lambda) #ops) - constraint 'a = [> 'a lambda] - method free = - function - | #var as x -> var#free x - | `Abs (s, t) -> Names.remove s ((!! free) t) - | `App (t1, t2) -> Names.union ((!! free) t1) ((!! free) t2) - method map ~f = - function - | #var as x -> x - | `Abs (s, t) as l -> - let t' = f t in if t == t' then l else `Abs (s, t') - | `App (t1, t2) as l -> - let t'1 = f t1 - and t'2 = f t2 in - if (t'1 == t1) && (t'2 == t2) then l else `App (t'1, t'2) - method subst ~sub = - function - | #var as x -> var#subst ~sub x - | `Abs (s, t) as l -> - let used = (!! free) t in - let used_expr = - Subst.fold sub ~init:[] - ~f:(fun ~key ~data acc -> - if Names.mem s used then data :: acc else acc) in - if List.exists used_expr ~f:(fun t -> Names.mem s ((!! free) t)) - then - let name = s ^ (Int.to_string (next_id ())) in - `Abs - (name, - ((!! subst) ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t)) - else self#map ~f:((!! subst) ~sub:(Subst.remove s sub)) l - | `App _ as l -> self#map ~f:((!! subst) ~sub) l - method eval l = - match self#map ~f:(!! eval) l with - | `App (`Abs (s, t1), t2) -> - (!! eval) - ((!! subst) ~sub:(Subst.add ~key:s ~data:t2 Subst.empty) t1) - | t -> t - end -let lambda = lazy_fix (new lambda_ops) -type 'a expr = - [ `Var of string | `Num of int | `Add of ('a * 'a) | `Neg of 'a - | `Mult of ('a * 'a) ] -class ['a] expr_ops (ops : ('a,'a) #ops Lazy.t)= - let var : 'a var_ops = new var_ops - and free = lazy ((!! ops)#free) - and subst = lazy ((!! ops)#subst) - and eval = lazy ((!! ops)#eval) in - object (self : ('a,'a expr) #ops) - constraint 'a = [> 'a expr] - method free = - function - | #var as x -> var#free x - | `Num _ -> Names.empty - | `Add (x, y) -> Names.union ((!! free) x) ((!! free) y) - | `Neg x -> (!! free) x - | `Mult (x, y) -> Names.union ((!! free) x) ((!! free) y) - method map ~f = - function - | #var as x -> x - | `Num _ as x -> x - | `Add (x, y) as e -> - let x' = f x - and y' = f y in if (x == x') && (y == y') then e else `Add (x', y') - | `Neg x as e -> let x' = f x in if x == x' then e else `Neg x' - | `Mult (x, y) as e -> - let x' = f x - and y' = f y in - if (x == x') && (y == y') then e else `Mult (x', y') - method subst ~sub = - function - | #var as x -> var#subst ~sub x - | #expr as e -> self#map ~f:((!! subst) ~sub) e - method eval (#expr as e) = - match self#map ~f:(!! eval) e with - | `Add (`Num m, `Num n) -> `Num (m + n) - | `Neg (`Num n) -> `Num (- n) - | `Mult (`Num m, `Num n) -> `Num (m * n) - | e -> e - end -let expr = lazy_fix (new expr_ops) -type 'a lexpr = [ | 'a lambda | 'a expr] -class ['a] lexpr_ops (ops : ('a,'a) #ops Lazy.t)= - let lambda = (new lambda_ops) ops in let expr = (new expr_ops) ops in - object (self : ('a,'a lexpr) #ops) - constraint 'a = [> 'a lexpr] - method free = - function | #lambda as x -> lambda#free x | #expr as x -> expr#free x - method subst ~sub = - function - | #lambda as x -> lambda#subst ~sub x - | #expr as x -> expr#subst ~sub x - method eval = - function | #lambda as x -> lambda#eval x | #expr as x -> expr#eval x - end -let lexpr = lazy_fix (new lexpr_ops) -let rec print = - function - | `Var id -> print_string id - | `Abs (id, l) -> (print_string (" " ^ (id ^ " . ")); print l) - | `App (l1, l2) -> (print l1; print_string " "; print l2) - | `Num x -> print_int x - | `Add (e1, e2) -> (print e1; print_string " + "; print e2) - | `Neg e -> (print_string "-"; print e) - | `Mult (e1, e2) -> (print e1; print_string " * "; print e2) -let () = - let e1 = lambda#eval (`App ((`Abs ("x", (`Var "x"))), (`Var "y"))) in - let e2 = expr#eval (`Add ((`Mult ((`Num 3), (`Neg (`Num 2)))), (`Var "x"))) in - let e3 = - lexpr#eval - (`Add - ((`App ((`Abs ("x", (`Mult ((`Var "x"), (`Var "x"))))), (`Num 2))), - (`Num 5))) in - print e1; - print_newline (); - print e2; - print_newline (); - print e3; - print_newline () -open StdLabels -open MoreLabels -module Subst = (Map.Make)(struct type t = string - let compare = compare end) -module Names = (Set.Make)(struct type t = string - let compare = compare end) -let lazy_fix make = - let rec obj () = make (lazy (obj ()) : _ Lazy.t) in obj () -let (!!) = Lazy.force -class type ['a,'b] ops = - object - method free : 'b -> Names.t - method subst : sub:'a Subst.t -> 'b -> 'a - method eval : 'b -> 'a - end -type var = [ `Var of string ] -let var = - object (self : ([> var],var) #ops) - method subst ~sub (`Var s as x) = - try Subst.find s sub with | Not_found -> x - method free (`Var s) = Names.singleton s - method eval (#var as v) = v - end -type 'a lambda = - [ `Var of string | `Abs of (string * 'a) | `App of ('a * 'a) ] -let next_id = let current = ref 3 in fun () -> incr current; !current -let lambda_ops (ops : ('a,'a) #ops Lazy.t) = - let free = lazy ((!! ops)#free) - and subst = lazy ((!! ops)#subst) - and eval = lazy ((!! ops)#eval) in - object (self : ([> 'a lambda],'a lambda) #ops) - method free = - function - | #var as x -> var#free x - | `Abs (s, t) -> Names.remove s ((!! free) t) - | `App (t1, t2) -> Names.union ((!! free) t1) ((!! free) t2) - method private map ~f = - function - | #var as x -> x - | `Abs (s, t) as l -> - let t' = f t in if t == t' then l else `Abs (s, t') - | `App (t1, t2) as l -> - let t'1 = f t1 - and t'2 = f t2 in - if (t'1 == t1) && (t'2 == t2) then l else `App (t'1, t'2) - method subst ~sub = - function - | #var as x -> var#subst ~sub x - | `Abs (s, t) as l -> - let used = (!! free) t in - let used_expr = - Subst.fold sub ~init:[] - ~f:(fun ~key ~data acc -> - if Names.mem s used then data :: acc else acc) in - if List.exists used_expr ~f:(fun t -> Names.mem s ((!! free) t)) - then - let name = s ^ (Int.to_string (next_id ())) in - `Abs - (name, - ((!! subst) ~sub:(Subst.add ~key:s ~data:(`Var name) sub) t)) - else self#map ~f:((!! subst) ~sub:(Subst.remove s sub)) l - | `App _ as l -> self#map ~f:((!! subst) ~sub) l - method eval l = - match self#map ~f:(!! eval) l with - | `App (`Abs (s, t1), t2) -> - (!! eval) - ((!! subst) ~sub:(Subst.add ~key:s ~data:t2 Subst.empty) t1) - | t -> t - end -let lambda = lazy_fix lambda_ops -type 'a expr = - [ `Var of string | `Num of int | `Add of ('a * 'a) | `Neg of 'a - | `Mult of ('a * 'a) ] -let expr_ops (ops : ('a,'a) #ops Lazy.t) = - let free = lazy ((!! ops)#free) - and subst = lazy ((!! ops)#subst) - and eval = lazy ((!! ops)#eval) in - object (self : ([> 'a expr],'a expr) #ops) - method free = - function - | #var as x -> var#free x - | `Num _ -> Names.empty - | `Add (x, y) -> Names.union ((!! free) x) ((!! free) y) - | `Neg x -> (!! free) x - | `Mult (x, y) -> Names.union ((!! free) x) ((!! free) y) - method private map ~f = - function - | #var as x -> x - | `Num _ as x -> x - | `Add (x, y) as e -> - let x' = f x - and y' = f y in if (x == x') && (y == y') then e else `Add (x', y') - | `Neg x as e -> let x' = f x in if x == x' then e else `Neg x' - | `Mult (x, y) as e -> - let x' = f x - and y' = f y in - if (x == x') && (y == y') then e else `Mult (x', y') - method subst ~sub = - function - | #var as x -> var#subst ~sub x - | #expr as e -> self#map ~f:((!! subst) ~sub) e - method eval (#expr as e) = - match self#map ~f:(!! eval) e with - | `Add (`Num m, `Num n) -> `Num (m + n) - | `Neg (`Num n) -> `Num (- n) - | `Mult (`Num m, `Num n) -> `Num (m * n) - | e -> e - end -let expr = lazy_fix expr_ops -type 'a lexpr = [ | 'a lambda | 'a expr] -let lexpr_ops (ops : ('a,'a) #ops Lazy.t) = - let lambda = lambda_ops ops in - let expr = expr_ops ops in - object (self : ([> 'a lexpr],'a lexpr) #ops) - method free = - function | #lambda as x -> lambda#free x | #expr as x -> expr#free x - method subst ~sub = - function - | #lambda as x -> lambda#subst ~sub x - | #expr as x -> expr#subst ~sub x - method eval = - function | #lambda as x -> lambda#eval x | #expr as x -> expr#eval x - end -let lexpr = lazy_fix lexpr_ops -let rec print = - function - | `Var id -> print_string id - | `Abs (id, l) -> (print_string (" " ^ (id ^ " . ")); print l) - | `App (l1, l2) -> (print l1; print_string " "; print l2) - | `Num x -> print_int x - | `Add (e1, e2) -> (print e1; print_string " + "; print e2) - | `Neg e -> (print_string "-"; print e) - | `Mult (e1, e2) -> (print e1; print_string " * "; print e2) -let () = - let e1 = lambda#eval (`App ((`Abs ("x", (`Var "x"))), (`Var "y"))) in - let e2 = expr#eval (`Add ((`Mult ((`Num 3), (`Neg (`Num 2)))), (`Var "x"))) in - let e3 = - lexpr#eval - (`Add - ((`App ((`Abs ("x", (`Mult ((`Var "x"), (`Var "x"))))), (`Num 2))), - (`Num 5))) in - print e1; - print_newline (); - print e2; - print_newline (); - print e3; - print_newline () -type sexp = - | A of string - | L of sexp list -type 'a t = 'a array -let _ = fun (_ : 'a t) -> () -let array_of_sexp _ _ = [||] -let sexp_of_array _ _ = A "foo" -let sexp_of_int _ = A "42" -let int_of_sexp _ = 42 -let t_of_sexp : 'a . (sexp -> 'a) -> sexp -> 'a t = - let _tp_loc = "core_array.ml.t" in - fun _of_a -> fun t -> (array_of_sexp _of_a) t -let _ = t_of_sexp -let sexp_of_t : 'a . ('a -> sexp) -> 'a t -> sexp = - fun _of_a -> fun v -> (sexp_of_array _of_a) v -let _ = sexp_of_t -module T = - struct - module Int = - struct - type t_ = int array - let _ = fun (_ : t_) -> () - let t__of_sexp : sexp -> t_ = - let _tp_loc = "core_array.ml.T.Int.t_" in - fun t -> (array_of_sexp int_of_sexp) t - let _ = t__of_sexp - let sexp_of_t_ : t_ -> sexp = fun v -> (sexp_of_array sexp_of_int) v - let _ = sexp_of_t_ - end - end -module type Permissioned = sig type ('a, -'perms) t end -module Permissioned : - sig - type ('a, -'perms) t - include - sig - val t_of_sexp : - (sexp -> 'a) -> (sexp -> 'perms) -> sexp -> ('a, 'perms) t - val sexp_of_t : - ('a -> sexp) -> ('perms -> sexp) -> ('a, 'perms) t -> sexp - end - module Int : - sig - type nonrec -'perms t = (int, 'perms) t - include - sig - val t_of_sexp : (sexp -> 'perms) -> sexp -> 'perms t - val sexp_of_t : ('perms -> sexp) -> 'perms t -> sexp - end - end - end = - struct - type ('a, -'perms) t = 'a array - let _ = fun (_ : ('a, 'perms) t) -> () - let t_of_sexp : - 'a 'perms . (sexp -> 'a) -> (sexp -> 'perms) -> sexp -> ('a, 'perms) t - = - let _tp_loc = "core_array.ml.Permissioned.t" in - fun _of_a -> fun _of_perms -> fun t -> (array_of_sexp _of_a) t - let _ = t_of_sexp - let sexp_of_t : - 'a 'perms . ('a -> sexp) -> ('perms -> sexp) -> ('a, 'perms) t -> sexp - = fun _of_a -> fun _of_perms -> fun v -> (sexp_of_array _of_a) v - let _ = sexp_of_t - module Int = - struct - include T.Int - type -'perms t = t_ - let _ = fun (_ : 'perms t) -> () - let t_of_sexp : 'perms . (sexp -> 'perms) -> sexp -> 'perms t = - let _tp_loc = "core_array.ml.Permissioned.Int.t" in - fun _of_perms -> fun t -> t__of_sexp t - let _ = t_of_sexp - let sexp_of_t : 'perms . ('perms -> sexp) -> 'perms t -> sexp = - fun _of_perms -> fun v -> sexp_of_t_ v - let _ = sexp_of_t - end - end -type 'a foo = { - x: 'a ; - y: int } -let r = { { x = 0; y = 0 } with x = 0 } -let r' : string foo = r -external foo : int = "%ignore" -let _ = foo () -type 'a t = [ `A of 'a t t ] as 'a -type 'a t = [ `A of 'a t t ] -type 'a t = [ `A of 'a t t ] constraint 'a = 'a t -type 'a t = [ `A of 'a t ] constraint 'a = 'a t -type 'a t = [ `A of 'a ] as 'a -type 'a v = [ `A of u v ] constraint 'a = t -and t = u -and u = t -type 'a t = 'a -let f (x : 'a t as 'a) = () -let f (x : 'a t) (y : 'a) = x = y -module type PR6505 = - sig - type 'o is_an_object = < .. > as 'o - and 'o abs constraint 'o = 'o is_an_object - val abs : 'o is_an_object -> 'o abs - val unabs : 'o abs -> 'o - end -let f ~x = x + 1 -;;f ?x:0 -let foo (f : unit -> unit) = () -let g ?x () = () -;;foo ((); g) -;;foo (fun ?opt () -> ()) -type 'a t = 'a -let f (g : 'a list -> 'a t -> 'a) s = g s s -let f (g : ('a * 'b) -> 'a t -> 'a) s = g s s -type ab = [ `A | `B ] -let f (x : [ `A ]) = match x with | #ab -> 1 -let f x = ignore (match x with | #ab -> 1); ignore (x : [ `A ]) -let f x = ignore (match x with | `A | `B -> 1); ignore (x : [ `A ]) -let f (x : [< `A | `B ]) = match x with | `A | `B | `C -> 0 -let f (x : [ `A | `B ]) = match x with | `A | `B | `C -> 0 -let revapply x f = f x -let f x (g : [< `Foo ]) = - let y = ((`Bar x), g) in revapply y (fun (`Bar i, _) -> i) -let rec x = [|x|]; 1. -let rec x = let u = [|y|] in 10. -and y = 1. -type 'a t -type a -let f : < .. > t -> unit = fun _ -> () -let g : [< `b ] t -> unit = fun _ -> () -let h : [> `b ] t -> unit = fun _ -> () -let _ = fun (x : a t) -> f x -let _ = fun (x : a t) -> g x -let _ = fun (x : a t) -> h x -type t = [ | 'A_name | `Hi ] -let f (x : 'id_arg) = x -let f (x : 'Id_arg) = x -type t = { - x: int ; - y: int } -;;{ x = 3; z = 2 } -;;fun { x = 3; z = 2 } -> () -;;{ x = 3; contents = 2 } -type u = private { - mutable u: int } -;;{ u = 3 } -;;fun x -> x.u <- 3 -module M = struct type t = { - x: int ; - y: int } end -let f { M.x = x; y } = x + y -let r = { M.x = 1; y = 2 } -let z = f r -type foo = { - mutable y: int } -let f (r : int) = r.y <- 3 -type foo = { - y: int ; - z: int } -type bar = { - x: int } -let f (r : bar) = ({ r with z = 3 } : foo) -type foo = { - x: int } -let r : foo = { ZZZ.x = 2 } -;;(ZZZ.X : int option) -let f (x : Complex.t) = x.Complex.z -module rec X:sig type t = (int * bool) end = - struct type t = - | A - | B - let f = function | A | B -> 0 end - -type _ prod = - | Prod: ('a * 'y) prod -let f : type t. t prod -> _ = - function | Prod -> let module M = struct type d = (d * d) end in () -let (a : M.a) = 2 -let (b : M.b) = 2 -let _ = A.a = B.b -module Std = struct module Hash = Hashtbl end -open Std -module Hash1 = (Hash : module type of Hash) -module Hash2 : sig include module type of Hash end = Hash -let f1 (x : (_, _) Hash1.t) = (x : (_, _) Hashtbl.t) -let f2 (x : (_, _) Hash2.t) = (x : (_, _) Hashtbl.t) -module Std2 = struct module M = struct type t end end -module Std' = Std2 -module M' = (Std2.M : module type of Std'.M) -let f3 (x : M'.t) = (x : Std2.M.t) -module type INCLUDING = - sig include module type of List include module type of ListLabels end -module Including_typed : INCLUDING = - struct include List - include ListLabels end -module X = - struct - module type SIG = sig type t = int val x : t end - module F(Y:SIG) : SIG = struct type t = Y.t - let x = Y.x end - end -module DUMMY = struct type t = int - let x = 2 end -let x = (3 : X.F(DUMMY).t) -module X2 = - struct - module type SIG = sig type t = int val x : t end - module F(Y:SIG)(Z:SIG) = - struct type t = Y.t - let x = Y.x - type t' = Z.t - let x' = Z.x end - end -let x = (3 : X2.F(DUMMY)(DUMMY).t) -let x = (3 : X2.F(DUMMY)(DUMMY).t') -module F(M:sig type 'a t type 'a u = string val f : unit -> _ u t end) = - struct let t = M.f () end -type 't a = [ `A ] -type 't wrap = 't constraint 't = [> 't wrap a] -type t = t a wrap -module T = - struct - let foo : 't wrap -> 't wrap -> unit = fun _ _ -> () - let bar : 'a a wrap as 'a = `A - end -module Good : sig val bar : t val foo : t -> t -> unit end = T -module Bad : sig val foo : t -> t -> unit val bar : t end = T -module M : sig module type T module F : functor (X : T) -> sig end end = - struct module type T = sig end - module F(X:T) = struct end end -module type T = M.T -module F = (M.F : functor (X : T) -> sig end) -module type S = sig type t = { - a: int ; - b: int } end -let f ((module M) : (module S with type t = int)) = { M.a = 0 } -let flag = ref false -module F(S:sig module type T end)(A:S.T)(B:S.T) = - struct - module X = (val - (if !flag then (module A) else (module B) : (module S.T))) - end -module type S = sig type t val x : t end -module Float = struct type t = float - let x = 0.0 end -module Int = struct type t = int - let x = 0 end -module M = (F)(struct module type T = S end) -let () = flag := false -module M1 = ((M)(Float))(Int) -let () = flag := true -module M2 = ((M)(Float))(Int) -let _ = [|M2.X.x;M1.X.x|] -module type PR6513 = - sig - module type S = sig type u end - module type T = sig type 'a wrap type uri end - module Make : - functor (Html5 : T with type 'a wrap = 'a) -> - S with type u = < foo: Html5.uri > - end -module type S = sig include Set.S module E : sig val x : int end end -module Make(O:Set.OrderedType) = - (struct include (Set.Make)(O) - module E = struct let x = 1 end end : S with type elt = O.t) -module rec A:Set.OrderedType = - struct type t = int - let compare = Stdlib.compare end - and B:S = struct module C = (Make)(A) - include C end -module type S = sig module type T module X : T end -module F(X:S) = X.X -module M = - struct - module type T = sig type t end - module X = struct type t = int end - end -type t = F(M).t -module Common0 = - struct - type msg = - | Msg - let handle_msg = - ref (function | _ -> failwith "Unable to handle message") - let extend_handle f = let old = !handle_msg in handle_msg := (f old) - let q : _ Queue.t = Queue.create () - let add msg = Queue.add msg q - let handle_queue_messages () = Queue.iter (!handle_msg) q - end -let q' : Common0.msg Queue.t = Common0.q -module Common = - struct - type msg = .. - let handle_msg = - ref (function | _ -> failwith "Unable to handle message") - let extend_handle f = let old = !handle_msg in handle_msg := (f old) - let q : _ Queue.t = Queue.create () - let add msg = Queue.add msg q - let handle_queue_messages () = Queue.iter (!handle_msg) q - end -module M1 = - struct - type Common.msg += - | Reload of string - | Alert of string - let handle fallback = - function - | Reload s -> print_endline ("Reload " ^ s) - | Alert s -> print_endline ("Alert " ^ s) - | x -> fallback x - let () = Common.extend_handle handle - let () = Common.add (Reload "config.file") - let () = Common.add (Alert "Initialisation done") - end -let should_reject = - let table = Hashtbl.create 1 in fun x y -> Hashtbl.add table x y -type 'a t = 'a option -let is_some = function | None -> false | Some _ -> true -let should_accept ?x () = is_some x -include struct let foo `Test = () - let wrap f `Test = f - let bar = wrap () end -let f () = - let module S = String in - let module N = (Map.Make)(S) in N.add "sum" 41 N.empty -module X = struct module Y = struct module type S = sig type t end end end -module Y = X.Y -type 'a arg_t = 'at constraint 'a = (module Y.S with type t = 'at) -type t = (module X.Y.S with type t = unit) -let f (x : t arg_t) = () -let () = f () -module type S = sig type a type b end -module Foo(Bar:S with type a = private [> `A ])(Baz:S with type b = - private - < b: Bar.b ;.. > ) = - struct end -module A = struct module type A_S = sig end - type t = (module A_S) end -module type S = sig type t end -let f (type a) ((module X) : (module S with type t = a)) = () -let _ = f (module A) -module A_annotated_alias = (A : S with type t = (module A.A_S)) -let _ = f (module A_annotated_alias) -let _ = - f ((module A_annotated_alias) : (module S with type t = (module A.A_S))) -module A_alias = A -module A_alias_expanded = struct include A_alias end -let _ = - f ((module A_alias_expanded) : (module S with type t = (module A.A_S))) -let _ = f (module A_alias_expanded) -let _ = f ((module A_alias) : (module S with type t = (module A.A_S))) -let _ = f (module A_alias) -module Foo(Bar:sig type a = private [> `A ] end)(Baz:module type of - struct include Bar end) = - struct end -module Bazoinks = struct type a = [ `A ] end -module Bug = ((Foo)(Bazoinks))(Bazoinks) -type (_, _) eq = - | Eq: ('a, 'a) eq -let cast : type a b. (a, b) eq -> a -> b = fun (Eq) x -> x -module Fix(F:sig type 'a f end) = - struct - type 'a fix = ('a, 'a F.f) eq - let uniq (type a) (type b) (Eq : a fix) (Eq : b fix) : (a, b) eq= Eq - end -module M = - struct - module type S = sig type a val v : a end - type 'a s = (module S with type a = 'a) - end -module B = struct class type a = object method a : 'a . 'a M.s -> 'a end end -module M' = M -module B' = B -class b : B.a = - object - method a : 'a . 'a M.s -> 'a= - fun (type a) ((module X) : (module M.S with type a = a)) -> X.v - end -class b' : B.a = - object - method a : 'a . 'a M'.s -> 'a= - fun (type a) ((module X) : (module M'.S with type a = a)) -> X.v - end -module type FOO = sig type t end -module type BAR = - sig module rec A: (FOO with type t = < b: B.t > ) and B: FOO end -module A = struct module type S - module S = struct end end -module F(_:sig end) = struct module type S - module S = A.S end -module M = struct end -module N = M -module G(X:F(N).S) : A.S = X -module F(_:sig end) = struct module type S end -module M = struct end -module N = M -module G(X:F(N).S) : F(M).S = X -module M : sig type make_dec val add_dec : make_dec -> unit end = - struct - type u - module Fast : - sig - type 'd t - val create : unit -> 'd t - module type S = - sig module Data : sig type t end val key : Data.t t end - module Register : functor (D : S) -> sig end - val attach : 'd t -> 'd -> unit - end = - struct - type 'd t = unit - let create () = () - module type S = - sig module Data : sig type t end val key : Data.t t end - module Register(D:S) = struct end - let attach _ _ = () - end - type make_dec - module Dem = - struct - module Data = struct type t = make_dec end - let key = Fast.create () - end - module EDem = (Fast.Register)(Dem) - let add_dec dec = Fast.attach Dem.key dec - end -module Simple = - struct - type 'a t - module type S = sig module Data : sig type t end val key : Data.t t end - module Register(D:S) = struct let key = D.key end - module M = - struct - module Data = struct type t = int end - let key : _ t = Obj.magic () - end - end -module EM = (Simple.Register)(Simple.M) -;;Simple.M.key -module Simple2 = - struct - type 'a t - module type S = sig module Data : sig type t end val key : Data.t t end - module M = - struct - module Data = struct type t = int end - let key : _ t = Obj.magic () - end - module Register(D:S) = struct let key = D.key end - module EM = (Simple.Register)(Simple.M) - let k : M.Data.t t = M.key - end -module rec M:sig external f : int -> int = "%identity" end = - struct external f : int -> int = "%identity" end - -module type S = sig type t - and s = t end -module type S' = S with type t := int -module type S = sig module rec M: sig end and N: sig end end -module type S' = S with module M := String -type -'a t -class type c = object method m : [ `A ] t end -module M : sig val v : ( #c as 'a) -> 'a end = - struct let v x = ignore (x :> c); x end -let id = let module M = struct end in fun x -> x -let ko = let module M = struct end in fun _ -> () -module M : sig type -'a t = private int end = - struct type +'a t = private int end -module type A = sig type t = - | X of int end -type u = - | X of bool -module type B = A with type t = u -module type S = sig exception Foo of int exception Foo of bool end -module F(X:sig end) = struct let x = 3 end -;;F.x -module C = Char -;;C.chr 66 -module C' = (C : module type of Char) -;;C'.chr 66 -module C3 = struct include Char end -;;C3.chr 66 -let f x = let module M = struct module L = List end in M.L.length x -let g x = let module L = List in L.length (L.map succ x) -module F(X:sig end) = Char -module C4 = (F)(struct end) -;;C4.chr 66 -module G(X:sig end) = struct module M = X end -module M = (G)(struct end) -module M' = struct module N = struct let x = 1 end - module N' = N end -;;M'.N'.x -module M'' : sig module N' : sig val x : int end end = M' -;;M''.N'.x -module M2 = struct include M' end -module M3 : sig module N' : sig val x : int end end = struct include M' end -;;M3.N'.x -module M3' : sig module N' : sig val x : int end end = M2 -;;M3'.N'.x -module M4 : sig module N' : sig val x : int end end = - struct module N = struct let x = 1 end - module N' = N end -;;M4.N'.x -module F(X:sig end) = - struct module N = struct let x = 1 end - module N' = N end -module G = - (F : functor (X : sig end) -> sig module N' : sig val x : int end end) -module M5 = (G)(struct end) -;;M5.N'.x -module M = - struct - module D = struct let y = 3 end - module N = struct let x = 1 end - module N' = N - end -module M1 : sig module N : sig val x : int end module N' = N end = M -;;M1.N'.x -module M2 : sig module N' : sig val x : int end end = - (M : sig module N : sig val x : int end module N' = N end) -;;M2.N'.x -open M -;;N'.x -module M = struct module C = Char - module C' = C end -module M1 : - sig module C : sig val escaped : char -> string end module C' = C end = M -;;M1.C'.escaped 'A' -module M2 : sig module C' : sig val chr : int -> char end end = - (M : sig module C : sig val chr : int -> char end module C' = C end) -;;M2.C'.chr 66 -;;StdLabels.List.map -module Q = Queue -exception QE = Q.Empty -;;try Q.pop (Q.create ()) with | QE -> "Ok" -module type Complex = module type of Complex with type t = Complex.t -module M : sig module C : Complex end = struct module C = Complex end -module C = Complex -;;C.one.Complex.re -include C -module F(X:sig module C = Char end) = struct module C = X.C end -module S = String -module StringSet = (Set.Make)(String) -module SSet = (Set.Make)(S) -let f (x : StringSet.t) = (x : SSet.t) -module F(M:sig end) : sig type t end = struct type t = int end -module T = struct module M = struct end - include (F)(M) end -include T -let f (x : t) : T.t= x -module A = - struct - module B = struct type t - let compare x y = 0 end - module S = (Set.Make)(B) - let empty = S.empty - end -module A1 = A -;;A1.empty = A.empty -module FF(X:sig end) = struct type t end -module M = struct module X = struct end - module Y = (FF)(X) - type t = Y.t end -module F(Y:sig type t end)(M:sig type t = Y.t end) = struct end -module G = (F)(M.Y) -module A1 = struct end -module A2 = struct end -module L1 = struct module X = A1 end -module L2 = struct module X = A2 end -module F(L:module type of L1) = struct end -module F1 = (F)(L1) -module F2 = (F)(L2) -module Int = struct type t = int - let compare = compare end -module SInt = (Set.Make)(Int) -type (_, _) eq = - | Eq: ('a, 'a) eq -type wrap = - | W of (SInt.t, SInt.t) eq -module M = - struct - module I = Int - type wrap' = wrap = - | W of (Set.Make(Int).t, Set.Make(I).t) eq - end -module type S = module type of M -module Int2 = struct type t = int - let compare x y = compare y x end -module type S' = sig module I = Int2 include S with module I := I end -module M = - struct - module N = struct module I = Int end - module P = struct module I = N.I end - module Q = - struct - type wrap' = wrap = - | W of (Set.Make(Int).t, Set.Make(P.I).t) eq - end - end -module type S = module type of M -module M = - struct - module N = struct module I = Int end - module P = struct module I = N.I end - module Q = - struct - type wrap' = wrap = - | W of (Set.Make(Int).t, Set.Make(N.I).t) eq - end - end -module type S = module type of M -module type S = sig module M : sig type t val x : t end end -module H = struct type t = - | A - let x = A end -module H' = H -module type S' = S with module M = H' -module type Alias = sig module N : sig end module M = N end -module F(X:sig end) = struct type t end -module type A = Alias with module N := F(List) -module rec Bad:A = Bad -module B = struct module R = struct type t = string end - module O = R end -module K = struct module E = B - module N = E.O end -let x : K.N.t = "foo" -module M = struct type t = - | A - module B = struct type u = - | B end end -module P : sig type t = M.t = - | A module B = M.B end = M -module P : sig type t = M.t = - | A module B = M.B end = struct include M end -module type S = sig module M : sig module P : sig end end module Q = M end -module type S = - sig - module M : sig module N : sig end module P : sig end end - module Q : sig module N = M.N module P = M.P end - end -module R = - struct - module M = struct module N = struct end - module P = struct end end - module Q = M - end -module R' : S = R -module M = struct let f x = x end -module rec R:sig module M : sig val f : 'a -> 'a end end = - struct module M = M end - -;;R.M.f 3 -module rec R:sig module M = M end = struct module M = M end -;;R.M.f 3 -open A -let f = L.map S.capitalize -let () = L.iter print_endline (f ["jacques"; "garrigue"]) -module C : sig module L : module type of List end = struct include A end -include D' -open A -let f = L.map S.capitalize -let () = L.iter print_endline (f ["jacques"; "garrigue"]) -module C : sig module L : module type of List end = struct include A end -let x = 3 -module M = struct let y = 5 end -module type S = sig type u type t end -module type S' = sig type t = int type u = bool end -let f (x : (module S with type t = 'a and type u = 'b)) = (x : (module S')) -let g x = (x : (module S with type t = 'a and type u = 'b) :> (module S')) -module type S2 = sig type u type t type w end -let g2 x = (x : (module S2 with type t = 'a and type u = 'b) :> (module S')) -let h x = (x : (module S2 with type t = 'a) :> (module S with type t = 'a)) -let f2 (x : (module S2 with type t = 'a and type u = 'b)) = (x : (module S')) -let k (x : (module S2 with type t = 'a)) = (x : (module S with type t = 'a)) -module type S3 = sig type u type t val x : int end -let g3 x = (x : (module S3 with type t = 'a and type u = 'b) :> (module S')) -module type S = sig val x : int end -let v = ((module struct let x = 3 end) : (module S)) -module F() = (val v) -module G(X:sig end) : S = (F)() -module H(X:sig end) = (val v) -module type S = sig type t val x : t end -let v = ((module struct type t = int - let x = 3 end) : (module S)) -module F() = (val v) -module G(X:sig end) : S = (F)() -module H() = (F)() -module U = struct end -module M = (F)(struct end) -module M = (F)(U) -module F1(X:sig end) = struct end -module F2 = (F1 : () -> sig end) -module F3() = struct end -module F4 = (F3 : functor (X : sig end) -> sig end) -module X(X:sig end)(Y:sig end)(Z:sig end) = struct end -module Y(X:sig end)(Y:sig end)(Z:sig end) = struct end -module Z(_:sig end)(_:sig end)(_:sig end) = struct end -module GZ = - (functor (X : sig end) -> functor () -> functor (Z : sig end) -> - struct end : - functor (X : sig end) -> () -> functor (Z : sig end) -> sig end) -module F(X:sig end) = struct type t = int end -module F(_:sig end) = struct type t = int end -type t = F(Does_not_exist).t -type expr = [ `Abs of (string * expr) | `App of (expr * expr) ] -class type exp = object method eval : (string, exp) Hashtbl.t -> expr end -class app e1 e2 : exp = - object - val l = e1 - val r = e2 - method eval env = - match l with - | `Abs (var, body) -> (Hashtbl.add env var r; body) - | _ -> `App (l, r) - end -class virtual ['subject,'event] observer = - object method virtual notify : 'subject -> 'event -> unit end -class ['event] subject = - object (self : 'subject) - val mutable observers = ([] : ('subject, 'event) observer list) - method add_observer obs = observers <- obs :: observers - method notify_observers (e : 'event) = - List.iter (fun x -> x#notify self e) observers - end -type id = int -class entity (id : id)= - object - val ent_destroy_subject = new subject - method destroy_subject : id subject= ent_destroy_subject - method entity_id = id - end -class ['entity] entity_container = - object (self) - inherit ['entity,id] observer as observer - method add_entity (e : 'entity) = (e#destroy_subject)#add_observer self - method notify _ id = () - end -let f (x : entity entity_container) = () -class c v= object initializer print_endline v val v = 42 end -;;(new c) "42" -class c (v : int)= - object - method v0 = v - inherit ((fun v -> object method v : string= v end) "42") - end -;;((new c) 42)#v0 -class virtual ['a] c = object (s : 'a) method virtual m : 'b end -let o = object (s : 'a) inherit ['a] c method m = 42 end -module M : sig class x : int -> object method m : int end end = - struct class x _= object method m = 42 end end -module M : sig class c : 'a -> object val x : 'b end end = - struct class c x= object val x = x end end -class c (x : int)= object inherit ((M.c) x) method x : bool= x end -let r = ((new c) 2)#x -class alfa = - object (_ : 'self) - method x : 'a . ('a, out_channel, unit) format -> 'a= Printf.printf - end -class bravo a= - object val y = (a :> alfa) initializer y#x "bravo initialized" end -class charlie a= - object inherit ((bravo) a) initializer y#x "charlie initialized" end -exception Out_of_range -class type ['a] cursor = - object method get : 'a method incr : unit -> unit method is_last : bool - end -class type ['a] storage = - object ('self) - method first : 'a cursor - method len : int - method nth : int -> 'a cursor - method copy : 'self - method sub : int -> int -> 'self - method concat : 'a storage -> 'self - method fold : 'b . ('a -> int -> 'b -> 'b) -> 'b -> 'b - method iter : ('a -> unit) -> unit - end -class virtual ['a,'cursor] storage_base = - object (self : 'self) - constraint 'cursor = 'a #cursor - method virtual first : 'cursor - method virtual len : int - method virtual copy : 'self - method virtual sub : int -> int -> 'self - method virtual concat : 'a storage -> 'self - method fold : 'b . ('a -> int -> 'b -> 'b) -> 'b -> 'b= - fun f a0 -> - let cur = self#first in - let rec loop count a = - if count >= self#len - then a - else - (let a' = f cur#get count a in cur#incr (); loop (count + 1) a') in - loop 0 a0 - method iter proc = - let p = self#first in - for i = 0 to self#len - 2 do (proc p#get; p#incr ()) done; - if self#len > 0 then proc p#get else () - end -class type ['a] obj_input_channel = - object method get : unit -> 'a method close : unit -> unit end -class type ['a] obj_output_channel = - object - method put : 'a -> unit - method flush : unit -> unit - method close : unit -> unit - end -module UChar = - struct - type t = int - let highest_bit = 1 lsl 30 - let lower_bits = highest_bit - 1 - let char_of c = - try Char.chr c with | Invalid_argument _ -> raise Out_of_range - let of_char = Char.code - let code c = if (c lsr 30) = 0 then c else raise Out_of_range - let chr n = - if (n >= 0) && ((n lsr 31) = 0) then n else raise Out_of_range - let uint_code c = c - let chr_of_uint n = n - end -type uchar = UChar.t -let int_of_uchar u = UChar.uint_code u -let uchar_of_int n = UChar.chr_of_uint n -class type ucursor = [uchar] cursor -class type ustorage = [uchar] storage -class virtual ['ucursor] ustorage_base = [uchar,'ucursor] storage_base -module UText = - struct - let get_buf s i = - let n = Char.code (s.[i]) in - let n = (n lsl 8) lor (Char.code (s.[i + 1])) in - let n = (n lsl 8) lor (Char.code (s.[i + 2])) in - let n = (n lsl 8) lor (Char.code (s.[i + 3])) in UChar.chr_of_uint n - let set_buf s i u = - let n = UChar.uint_code u in - s.![i] <- (Char.chr (n lsr 24)); - s.![(i + 1)] <- (Char.chr ((n lsr 16) lor 0xff)); - s.![(i + 2)] <- (Char.chr ((n lsr 8) lor 0xff)); - s.![(i + 3)] <- (Char.chr (n lor 0xff)) - let init_buf buf pos init = - if init#len = 0 - then () - else - (let cur = init#first in - for i = 0 to init#len - 2 do - (set_buf buf (pos + (i lsl 2)) cur#get; cur#incr ()) - done; - set_buf buf (pos + ((init#len - 1) lsl 2)) cur#get) - let make_buf init = - let s = String.create (init#len lsl 2) in init_buf s 0 init; s - class text_raw buf= - object (self : 'self) - inherit [cursor] ustorage_base - val contents = buf - method first = (new cursor) (self :> text_raw) 0 - method len = (String.length contents) / 4 - method get i = get_buf contents (4 * i) - method nth i = (new cursor) (self :> text_raw) i - method copy = {} - method sub pos len = - {} - method concat (text : ustorage) = - let buf = String.create ((String.length contents) + (4 * text#len)) in - String.blit contents 0 buf 0 (String.length contents); - init_buf buf (String.length contents) text; - {} - end - and cursor text i = - object - val contents = text - val mutable pos = i - method get = contents#get pos - method incr () = pos <- pos + 1 - method is_last = (pos + 1) >= contents#len - end - class string_raw buf= - object - inherit ((text_raw) buf) - method set i u = set_buf contents (4 * i) u - end - class text init= ((text_raw) (make_buf init)) - class string init= ((string_raw) (make_buf init)) - let of_string s = - let buf = String.make (4 * (String.length s)) '\000' in - for i = 0 to (String.length s) - 1 do buf.![(4 * i)] <- (s.[i]) done; - (new text_raw) buf - let make len u = - let s = String.create (4 * len) in - for i = 0 to len - 1 do set_buf s (4 * i) u done; (new string_raw) s - let create len = make len (UChar.chr 0) - let copy s = s#copy - let sub s start len = s#sub start len - let fill s start len u = - for i = start to (start + len) - 1 do s#set i u done - let blit src srcoff dst dstoff len = - for i = 0 to len - 1 do - let u = src#get (srcoff + i) in dst#set (dstoff + i) u - done - let concat s1 s2 = s1#concat (s2 :> uchar storage) - let iter proc s = s#iter proc - end -class type foo_t = object method foo : string end -type 'a name = - | Foo: foo_t name - | Int: int name -class foo = - object (self) - method foo = "foo" - method cast = function | Foo -> (self :> < foo: string > ) - end -class foo : foo_t = - object (self) - method foo = "foo" - method cast : 'a . 'a name -> 'a= - fun (type a) -> - (function | Foo -> (self :> foo_t) | _ -> raise Exit : a name -> a) - end -class type c = object end -module type S = sig class c : c end -class virtual name = object end -and func (args_ty, ret_ty)= - object (self) - inherit name - val mutable memo_args = None - method arguments = - match memo_args with - | Some xs -> xs - | None -> - let args = List.map (fun ty -> (new argument) (self, ty)) args_ty in - (memo_args <- Some args; args) - end -and argument (func, ty)= object inherit name end -let f (x : #M.foo) = 0 -class type ['e] t = object ('s) method update : 'e -> 's end -module type S = sig class base : 'e -> ['e] t end -type 'par t = 'par -module M : sig val x : < m: 'a . 'a > end = - struct let x : < m: 'a . 'a t > = Obj.magic () end -let ident v = v -class alias = object method alias : 'a . 'a t -> 'a= ident end -module Classdef = - struct - class virtual ['a,'b,'c] cl0 = - object constraint 'c = < m: 'a -> 'b -> int ;.. > end - class virtual ['a,'b] cl1 = - object - method virtual raise_trouble : int -> 'a - method virtual m : 'a -> 'b -> int - end - class virtual ['a,'b] cl2 = - object method virtual as_cl0 : ('a, 'b, ('a, 'b) cl1) cl0 end - end -type refer1 = < poly: 'a 'b 'c . ('b,'c) #Classdef.cl2 as 'a > -type refer2 = < poly: 'a 'b 'c . ('b,'c) #Classdef.cl2 as 'a > -let f (x : refer1) = (x : refer2) -module Classdef = - struct - class virtual ['a,'b,'c] cl0 = - object constraint 'c = < m: 'a -> 'b -> int ;.. > end - class virtual ['a,'b] cl1 = - object - method virtual raise_trouble : int -> 'a - method virtual m : 'a -> 'b -> int - end - class virtual ['a,'b] cl2 = - object method virtual as_cl0 : ('a, 'b, ('a, 'b) cl1) cl0 end - end -module M : - sig type refer = { - poly: 'a 'b 'c . ('b,'c) #Classdef.cl2 as 'a } end = - struct type refer = { - poly: 'a 'b 'c . ('b,'c) #Classdef.cl2 as 'a } end -open Pr3918b -let f x = (x : 'a vlist :> 'b vlist) -let f (x : 'a vlist) = (x : 'b vlist) -module type Poly = sig type 'a t = 'a constraint 'a = [>] end -module Combine(A:Poly)(B:Poly) = - struct type ('a, 'b) t = 'a A.t constraint 'a = 'b B.t end -module C = - ((Combine)(struct type 'a t = 'a constraint 'a = [>] end))(struct - type 'a t = - 'a - constraint - 'a = - [>] - end) -module type Priv = sig type t = private int end -module Make(Unit:sig end) : Priv = struct type t = int end -module A = (Make)(struct end) -module type Priv' = sig type t = private [> `A ] end -module Make'(Unit:sig end) : Priv' = struct type t = [ `A ] end -module A' = (Make')(struct end) -module TT = - struct - module IntSet = (Set.Make)(struct type t = int - let compare = compare end) - end -let () = - let f flag = - let module T = TT in - let _ = match flag with | `A -> 0 | `B r -> r in - let _ = match flag with | `A -> T.IntSet.mem | `B r -> r in () in - f `A -let f flag = - let module T = (Set.Make)(struct type t = int - let compare = compare end) in - let _ = match flag with | `A -> 0 | `B r -> r in - let _ = match flag with | `A -> T.mem | `B r -> r in () -module type S = - sig type +'a t val foo : [ `A ] t -> unit val bar : [< `A | `B ] t -> unit - end -module Make(T:S) = - struct let f x = T.foo x; T.bar x; (x :> [ `A | `C ] T.t) end -type 'a termpc = - [ `And of ('a * 'a) | `Or of ('a * 'a) | `Not of 'a | `Atom of string ] -type 'a termk = [ `Dia of 'a | `Box of 'a | 'a termpc] -module type T = - sig - type term - val map : (term -> term) -> term -> term - val nnf : term -> term - val nnf_not : term -> term - end -module Fpc(X:T with type term = private [> 'a termpc] as 'a) = - struct - type term = X.term termpc - let nnf = - function - | `Not (`Atom _) as x -> x - | `Not x -> X.nnf_not x - | x -> X.map X.nnf x - let map f : term -> X.term= - function - | `Not x -> `Not (f x) - | `And (x, y) -> `And ((f x), (f y)) - | `Or (x, y) -> `Or ((f x), (f y)) - | `Atom _ as x -> x - let nnf_not : term -> _ = - function - | `Not x -> X.nnf x - | `And (x, y) -> `Or ((X.nnf_not x), (X.nnf_not y)) - | `Or (x, y) -> `And ((X.nnf_not x), (X.nnf_not y)) - | `Atom _ as x -> `Not x - end -module Fk(X:T with type term = private [> 'a termk] as 'a) = - struct - type term = X.term termk - module Pc = (Fpc)(X) - let map f : term -> _= - function - | `Dia x -> `Dia (f x) - | `Box x -> `Box (f x) - | #termpc as x -> Pc.map f x - let nnf = Pc.nnf - let nnf_not : term -> _ = - function - | `Dia x -> `Box (X.nnf_not x) - | `Box x -> `Dia (X.nnf_not x) - | #termpc as x -> Pc.nnf_not x - end -type untyped -type -'a typed = private untyped -type -'typing wrapped = private sexp -and +'a t = 'a typed wrapped -and sexp = private untyped wrapped -class type ['a] s3 = object val underlying : 'a t end -class ['a] s3object r: ['a] s3 = object val underlying = r end -module M(T:sig type t end) = struct type t = private { - t: T.t } end -module P = struct module T = struct type t end - module R = (M)(T) end -module Foobar : sig type t = private int end = struct type t = int end -module F0 : sig type t = private int end = Foobar -let f (x : F0.t) = (x : Foobar.t) -module F = Foobar -let f (x : F.t) = (x : Foobar.t) -module M = struct type t = < m: int > end -module M1 : sig type t = private < m: int ;.. > end = M -module M2 : sig type t = private < m: int ;.. > end = M1 -;;fun (x : M1.t) -> (x : M2.t) -module M3 : sig type t = private M1.t end = M1 -;;fun x -> (x : M3.t :> M1.t) -;;fun x -> (x : M3.t :> M.t) -module M4 : sig type t = private M3.t end = M2 -module M4 : sig type t = private M3.t end = M -module M4 : sig type t = private M3.t end = M1 -module M5 : sig type t = private M1.t end = M3 -module M6 : sig type t = private < n: int ;.. > end = M1 -module Bar : sig type t = private Foobar.t val f : int -> t end = - struct type t = int - let f (x : int) = (x : t) end -module M : sig type t = private - | T of int val mk : int -> t end = - struct type t = - | T of int - let mk x = T x end -module M1 : sig type t = M.t val mk : int -> t end = - struct type t = M.t - let mk = M.mk end -module M2 : sig type t = M.t val mk : int -> t end = struct include M end -module M3 : sig type t = M.t val mk : int -> t end = M -module M4 : sig type t = M.t = - | T of int val mk : int -> t end = M -module M5 : sig type t = M.t = private - | T of int val mk : int -> t end = M -module M6 : sig type t = private - | T of int val mk : int -> t end = M -module M' : - sig type t_priv = private - | T of int type t = t_priv val mk : int -> t end = - struct type t_priv = - | T of int - type t = t_priv - let mk x = T x end -module M3' : sig type t = M'.t val mk : int -> t end = M' -module M : sig type 'a t = private - | T of 'a end = struct type 'a t = - | T of 'a end -module M1 : sig type 'a t = 'a M.t = private - | T of 'a end = - struct type 'a t = 'a M.t = private - | T of 'a end -module Test = struct type t = private - | A end -module Test2 = (Test : module type of Test with type t = Test.t) -let f (x : Test.t) = (x : Test2.t) -let f (Test2.A) = () -let a = Test2.A -module Test2 = (Test : module type of Test with type t = private Test.t) -type t = private < x: int ;.. > as 'a -type t = private (< x: int ;.. > as 'a) as 'a -type t = private < x: int > as 'a -type t = private (< x: int > as 'a) as 'b -type 'a t = private < x: int ;.. > as 'a -type 'a t = private 'a constraint 'a = < x: int ;.. > -module rec A:sig type t = A.t end = struct type t = A.t end -module rec A:sig type t = B.t end = struct type t = B.t end - and B:sig type t = A.t end = struct type t = A.t end -module rec A:sig type t = B.t end = struct type t = B.t end - and B:sig type t = int end = struct type t = int end -module rec A:sig type t = (int * A.t) end = struct type t = (int * A.t) end -module rec A:sig type t = B.t -> int end = struct type t = B.t -> int end - and B:sig type t = A.t end = struct type t = A.t end -module rec A:sig type t = < m: B.t > end = - struct type t = < m: B.t > end - and B:sig type t = A.t end = struct type t = A.t end -module rec A:sig type 'a t = < m: 'a list A.t > end = - struct type 'a t = < m: 'a list A.t > end - -module rec A:sig type 'a t = < m: 'a list B.t ;n: 'a array B.t > end = - struct type 'a t = < m: 'a list B.t ;n: 'a array B.t > end - and B:sig type 'a t = 'a A.t end = struct type 'a t = 'a A.t end -module rec A:sig type 'a t = 'a B.t end = struct type 'a t = 'a B.t end - and B:sig type 'a t = < m: 'a list A.t ;n: 'a array A.t > end = - struct type 'a t = < m: 'a list A.t ;n: 'a array A.t > end -module rec A:sig type 'a t = ('a array B.t * 'a list B.t) end = - struct type 'a t = ('a array B.t * 'a list B.t) end - and B:sig type 'a t = < m: 'a B.t > end = - struct type 'a t = < m: 'a B.t > end -module rec A:sig type 'a t = 'a list B.t end = - struct type 'a t = 'a list B.t end - and B:sig type 'a t = < m: 'a array B.t > end = - struct type 'a t = < m: 'a array B.t > end -module rec - M:sig class ['a] c : 'a -> object method map : ('a -> 'b) -> 'b M.c end - end = - struct - class ['a] c (x : 'a)= - object method map : 'b . ('a -> 'b) -> 'b M.c= fun f -> (new M.c) (f x) - end - end - -class type ['node] extension = object method node : 'node end -and ['ext] node = object constraint 'ext = (('ext node #extension)[@id ]) end -class x = object method node : x node= assert false end -type t = x node -module PR_4261 = - struct - module type S = sig type t end - module type T = sig module D : S type t = D.t end - module rec U:T with module D = U' = U and U':S with type t = U'.t = U - end -module type S' = sig type t = int end -module rec M:S' with type t = M.t = struct type t = M.t end -module PR_4450_1 = - struct - module type MyT = sig type 'a t = - | Succ of 'a t end - module MyMap(X:MyT) = X - module rec MyList:MyT = (MyMap)(MyList) - end -module PR_4450_2 = - struct - module type MyT = - sig - type 'a wrap = - | My of 'a t - and 'a t = private < map: 'b . ('a -> 'b) -> 'b wrap ;.. > - val create : 'a list -> 'a t - end - module MyMap(X:MyT) = - struct - include X - class ['a] c l= - object (self) - method map : 'b . ('a -> 'b) -> 'b wrap= - fun f -> My (create (List.map f l)) - end - end - module rec - MyList:sig - type 'a wrap = - | My of 'a t - and 'a t = < map: 'b . ('a -> 'b) -> 'b wrap > - val create : 'a list -> 'a t - end = struct include (MyMap)(MyList) - let create l = (new c) l end - - end -module type ORD = sig type t val compare : t -> t -> int end -module type SET = - sig type elt type t val iter : (elt -> unit) -> t -> unit end -type 'a tree = - | E - | N of 'a tree * 'a * 'a tree -module Bootstrap2(MakeDiet:functor (X : ORD) -> - SET with type t = X.t tree and type elt = - X.t) = - (struct - type elt = int - module rec - Elt:sig - type t = - | I of int * int - | D of int * Diet.t * int - val compare : t -> t -> int - val iter : (int -> unit) -> t -> unit - end = - struct - type t = - | I of int * int - | D of int * Diet.t * int - let compare x1 x2 = 0 - let rec iter f = - function - | I (l, r) -> for i = l to r do f i done - | D (_, d, _) -> Diet.iter (iter f) d - end - and Diet:SET with type t = Elt.t tree and type elt = Elt.t = - (MakeDiet)(Elt) - type t = Diet.t - let iter f = Diet.iter (Elt.iter f) - end : SET with type elt = int) -module rec DirElt:sig type t = - | DirRoot - | DirSub of DirHash.t end = - struct type t = - | DirRoot - | DirSub of DirHash.t end - and DirCompare:sig type t = DirElt.t end = struct type t = DirElt.t end - and DirHash:sig type t = DirElt.t list end = - struct type t = DirCompare.t list end -module PR_4758 = - struct - module type S = sig end - module type Mod = sig module Other : S end - module rec A:S = struct end - and C:sig include Mod with module Other = A end = - struct module Other = A end - module C' = C - module F(X:sig end) = struct type t end - let f (x : F(C).t) = (x : F(C').t) - end -module PR_4557 = - struct - module F(X:Set.OrderedType) = - struct - module rec - Mod:sig - module XSet : sig type elt = X.t type t = Set.Make(X).t end - module XMap : - sig type key = X.t type 'a t = 'a Map.Make(X).t end - type elt = X.t - type t = XSet.t XMap.t - val compare : t -> t -> int - end = - struct - module XSet = (Set.Make)(X) - module XMap = (Map.Make)(X) - type elt = X.t - type t = XSet.t XMap.t - let compare x y = 0 - end - and ModSet:Set.S with type elt = Mod.t = (Set.Make)(Mod) - end - end -module F(X:Set.OrderedType) = - struct - module rec - Mod:sig - module XSet : sig type elt = X.t type t = Set.Make(X).t end - module XMap : sig type key = X.t type 'a t = 'a Map.Make(X).t end - type elt = X.t - type t = XSet.t XMap.t - val compare : t -> t -> int - end = - struct - module XSet = (Set.Make)(X) - module XMap = (Map.Make)(X) - type elt = X.t - type t = XSet.t XMap.t - let compare x y = 0 - end - and ModSet:Set.S with type elt = Mod.t = (Set.Make)(Mod) - end -let test number result expected = - if result = expected - then Printf.printf "Test %d passed.\n" number - else Printf.printf "Test %d FAILED.\n" number; - flush stdout -module rec - A:sig type t = - | Leaf of int - | Node of ASet.t val compare : t -> t -> int - end = - struct - type t = - | Leaf of int - | Node of ASet.t - let compare x y = - match (x, y) with - | (Leaf i, Leaf j) -> Stdlib.compare i j - | (Leaf i, Node t) -> (-1) - | (Node s, Leaf j) -> 1 - | (Node s, Node t) -> ASet.compare s t - end - and ASet:Set.S with type elt = A.t = (Set.Make)(A) -let _ = - let x = A.Node (ASet.add (A.Leaf 3) (ASet.singleton (A.Leaf 2))) in - let y = A.Node (ASet.add (A.Leaf 1) (ASet.singleton x)) in - test 10 (A.compare x x) 0; - test 11 (A.compare x (A.Leaf 3)) 1; - test 12 (A.compare (A.Leaf 0) x) (-1); - test 13 (A.compare y y) 0; - test 14 (A.compare x y) 1 -module rec Fib:sig val f : int -> int end = - struct let f x = if x < 2 then 1 else (Fib.f (x - 1)) + (Fib.f (x - 2)) end - -let _ = test 20 (Fib.f 10) 89 -module rec Fib2:sig val f : int -> int end = - struct - let rec g x = (Fib2.f (x - 1)) + (Fib2.f (x - 2)) - and f x = if x < 2 then 1 else g x - end - -let _ = test 21 (Fib2.f 10) 89 -let _ = - let res = - try - let module A = - struct - module rec Bad:sig val f : int -> int end = - struct let f = let y = Bad.f 5 in fun x -> x + y end - - end in false - with | Undefined_recursive_module _ -> true in - test 30 res true -module rec After:sig val x : int end = struct let x = Before.x + 1 end - and Before:sig val x : int end = struct let x = 3 end -let _ = test 40 After.x 4 -module rec Strengthen:sig type t val f : t -> t end = - struct - type t = - | A - | B - let _ = (A : Strengthen.t) - let f x = if true then A else Strengthen.f B - end - -module rec - Strengthen2:sig - type t - val f : t -> t - module M : sig type u end - module R : sig type v end - end = - struct - type t = - | A - | B - let _ = (A : Strengthen2.t) - let f x = if true then A else Strengthen2.f B - module M = struct type u = - | C - let _ = (C : Strengthen2.M.u) end - module rec R:sig type v = Strengthen2.R.v end = - struct type v = - | D - let _ = (D : R.v) - let _ = (D : Strengthen2.R.v) end - - end - -module rec - PolyRec:sig - type 'a t = - | Leaf of 'a - | Node of 'a list t * 'a list t - val depth : 'a t -> int - end = - struct - type 'a t = - | Leaf of 'a - | Node of 'a list t * 'a list t - let x = (PolyRec.Leaf 1 : int t) - let depth = - function - | Leaf x -> 0 - | Node (l, r) -> 1 + (max (PolyRec.depth l) (PolyRec.depth r)) - end - -module StringSet = (Set.Make)(String) -module rec - Expr:sig - type t = - | Var of string - | Const of int - | Add of t * t - | Binding of Binding.t * t - val make_let : string -> t -> t -> t - val fv : t -> StringSet.t - val simpl : t -> t - end = - struct - type t = - | Var of string - | Const of int - | Add of t * t - | Binding of Binding.t * t - let make_let id e1 e2 = Binding ([(id, e1)], e2) - let rec fv = - function - | Var s -> StringSet.singleton s - | Const n -> StringSet.empty - | Add (t1, t2) -> StringSet.union (fv t1) (fv t2) - | Binding (b, t) -> - StringSet.union (Binding.fv b) - (StringSet.diff (fv t) (Binding.bv b)) - let rec simpl = - function - | Var s -> Var s - | Const n -> Const n - | Add (Const i, Const j) -> Const (i + j) - | Add (Const 0, t) -> simpl t - | Add (t, Const 0) -> simpl t - | Add (t1, t2) -> Add ((simpl t1), (simpl t2)) - | Binding (b, t) -> Binding ((Binding.simpl b), (simpl t)) - end - and - Binding:sig - type t = (string * Expr.t) list - val fv : t -> StringSet.t - val bv : t -> StringSet.t - val simpl : t -> t - end = - struct - type t = (string * Expr.t) list - let fv b = - List.fold_left (fun v (id, e) -> StringSet.union v (Expr.fv e)) - StringSet.empty b - let bv b = - List.fold_left (fun v (id, e) -> StringSet.add id v) StringSet.empty b - let simpl b = List.map (fun (id, e) -> (id, (Expr.simpl e))) b - end -let _ = - let e = - Expr.make_let "x" (Expr.Add ((Expr.Var "y"), (Expr.Const 0))) - (Expr.Var "x") in - let e' = Expr.make_let "x" (Expr.Var "y") (Expr.Var "x") in - test 50 (StringSet.elements (Expr.fv e)) ["y"]; test 51 (Expr.simpl e) e' -module type ORDERED = - sig - type t - val eq : t -> t -> bool - val lt : t -> t -> bool - val leq : t -> t -> bool - end -module type HEAP = - sig - module Elem : ORDERED - type heap - val empty : heap - val isEmpty : heap -> bool - val insert : Elem.t -> heap -> heap - val merge : heap -> heap -> heap - val findMin : heap -> Elem.t - val deleteMin : heap -> heap - end -module Bootstrap(MakeH:functor (Element : ORDERED) -> - HEAP with module Elem = Element)(Element:ORDERED) = - (struct - module Elem = Element - module rec - BE:sig - type t = - | E - | H of Elem.t * PrimH.heap - val eq : t -> t -> bool - val lt : t -> t -> bool - val leq : t -> t -> bool - end = - struct - type t = - | E - | H of Elem.t * PrimH.heap - let leq t1 t2 = - match (t1, t2) with - | (H (x, _), H (y, _)) -> Elem.leq x y - | (H _, E) -> false - | (E, H _) -> true - | (E, E) -> true - let eq t1 t2 = - match (t1, t2) with - | (H (x, _), H (y, _)) -> Elem.eq x y - | (H _, E) -> false - | (E, H _) -> false - | (E, E) -> true - let lt t1 t2 = - match (t1, t2) with - | (H (x, _), H (y, _)) -> Elem.lt x y - | (H _, E) -> false - | (E, H _) -> true - | (E, E) -> false - end - and PrimH:HEAP with type Elem.t = BE.t = (MakeH)(BE) - type heap = BE.t - let empty = BE.E - let isEmpty = function | BE.E -> true | _ -> false - let rec merge x y = - match (x, y) with - | (BE.E, _) -> y - | (_, BE.E) -> x - | ((BE.H (e1, p1) as h1), (BE.H (e2, p2) as h2)) -> - if Elem.leq e1 e2 - then BE.H (e1, (PrimH.insert h2 p1)) - else BE.H (e2, (PrimH.insert h1 p2)) - let insert x h = merge (BE.H (x, PrimH.empty)) h - let findMin = function | BE.E -> raise Not_found | BE.H (x, _) -> x - let deleteMin = - function - | BE.E -> raise Not_found - | BE.H (x, p) -> - if PrimH.isEmpty p - then BE.E - else - (match PrimH.findMin p with - | BE.H (y, p1) -> - let p2 = PrimH.deleteMin p in BE.H (y, (PrimH.merge p1 p2)) - | BE.E -> assert false) - end : HEAP with module Elem = Element) -module LeftistHeap(Element:ORDERED) = - (struct - module Elem = Element - type heap = - | E - | T of int * Elem.t * heap * heap - let rank = function | E -> 0 | T (r, _, _, _) -> r - let make x a b = - if (rank a) >= (rank b) - then T (((rank b) + 1), x, a, b) - else T (((rank a) + 1), x, b, a) - let empty = E - let isEmpty = function | E -> true | _ -> false - let rec merge h1 h2 = - match (h1, h2) with - | (_, E) -> h1 - | (E, _) -> h2 - | (T (_, x1, a1, b1), T (_, x2, a2, b2)) -> - if Elem.leq x1 x2 - then make x1 a1 (merge b1 h2) - else make x2 a2 (merge h1 b2) - let insert x h = merge (T (1, x, E, E)) h - let findMin = function | E -> raise Not_found | T (_, x, _, _) -> x - let deleteMin = - function | E -> raise Not_found | T (_, x, a, b) -> merge a b - end : HEAP with module Elem = Element) -module Ints = struct type t = int - let eq = (=) - let lt = (<) - let leq = (<=) end -module C = ((Bootstrap)(LeftistHeap))(Ints) -let _ = - let h = List.fold_right C.insert [6; 4; 8; 7; 3; 1] C.empty in - test 60 (C.findMin h) 1; - test 61 (C.findMin (C.deleteMin h)) 3; - test 62 (C.findMin (C.deleteMin (C.deleteMin h))) 4 -module rec Class1:sig class c : object method m : int -> int end end = - struct - class c = - object method m x = if x <= 0 then x else (new Class2.d)#m x end - end - and Class2:sig class d : object method m : int -> int end end = - struct - class d = - object (self) inherit Class1.c as super method m (x : int) = super#m 0 - end - end -let _ = test 70 ((new Class1.c)#m 7) 0 -let _ = - try - let module A = - struct - module rec BadClass1:sig class c : object method m : int end end = - struct class c = object method m = 123 end end - and BadClass2:sig val x : int end = - struct let x = (new BadClass1.c)#m end - end in test 71 true false - with | Undefined_recursive_module _ -> test 71 true true -module rec Coerce1:sig val g : int -> int val f : int -> int end = - struct - module A : sig val f : int -> int end = Coerce1 - let g x = x - let f x = if x <= 0 then 1 else (A.f (x - 1)) * x - end - -let _ = test 80 (Coerce1.f 10) 3628800 -module CoerceF(S:sig end) = - struct - let f1 () = 1 - let f2 () = 2 - let f3 () = 3 - let f4 () = 4 - let f5 () = 5 - end -module rec Coerce2:sig val f1 : unit -> int end = (CoerceF)(Coerce3) - and Coerce3:sig end = struct end -let _ = test 81 (Coerce2.f1 ()) 1 -module Coerce4(A:sig val f : int -> int end) = - struct let x = 0 - let at a = A.f a end -module rec Coerce5:sig val blabla : int -> int val f : int -> int end = - struct let blabla x = 0 - let f x = 5 end - and Coerce6:sig val at : int -> int end = (Coerce4)(Coerce5) -let _ = test 82 (Coerce6.at 100) 5 -module rec F:sig type t = - | X of int - | Y of int val f : t -> bool end = - struct - type t = - | X of int - | Y of int - let f = function | X _ -> false | _ -> true - end - -let _ = test 100 (F.f (F.X 1)) false; test 101 (F.f (F.Y 2)) true -module G(S:sig val x : int Lazy.t end) = struct include S end -module M1 = struct let x = lazy 3 end -let _ = Lazy.force M1.x -module rec M2:sig val x : int Lazy.t end = (G)(M1) -let _ = test 102 (Lazy.force M2.x) 3 -let _ = Gc.full_major () -module rec M3:sig val x : int Lazy.t end = (G)(M1) -let _ = test 103 (Lazy.force M3.x) 3 -type t = - | A of { - x: int ; - mutable y: int } [@@ocaml.doc - " Pure type-checking tests: see recmod/*.ml "] -let f (A r) = r -let f (A r) = r.x -let f x = A { x; y = x } -let f (A r) = A { r with y = (r.x + 1) } -let f () = A { a = 1 } -let f () = A { x = 1; y = 3 } -type _ t = - | A: { - x: 'a ; - y: 'b } -> 'a t -let f (A { x; y }) = A { x; y = () } -let f (A ({ x; y } as r)) = A { x = (r.x); y = (r.y) } -module M = - struct - type 'a t = - | A of { - x: 'a } - | B: { - u: 'b } -> unit t - exception Foo of { - x: int } - end -module N : - sig - type 'b t = 'b M.t = - | A of { - x: 'b } - | B: { - u: 'bla } -> unit t - exception Foo of { - x: int } - end = - struct - type 'b t = 'b M.t = - | A of { - x: 'b } - | B: { - u: 'z } -> unit t - exception Foo = M.Foo - end -module type S = sig exception A of { - x: int } end -module F(X:sig val x : (module S) end) = struct module A = (val X.x) end -module type S = - sig exception A of { - x: int } exception A of { - x: string } end -module M = struct exception A of { - x: int } - exception A of { - x: string } end -module M1 = struct exception A of { - x: int } end -module M = struct include M1 - include M1 end -module type S1 = sig exception A of { - x: int } end -module type S = sig include S1 include S1 end -module M = struct exception A = M1.A end -module X1 = struct type t = .. end -module X2 = struct type t = .. end -module Z = - struct type X1.t += - | A of { - x: int } - type X2.t += - | A of { - x: int } end -type _ c = - | C: [ `A ] c -type t = - | T: { - x: [< `A ] c } -> t -let f (T { x = C }) = () -module M : - sig type 'a t type u = u t - and v = v t val f : int -> u val g : v -> bool - end = - struct type 'a t = 'a - type u = int - and v = bool - let f x = x - let g x = x end -let h (x : int) : bool= M.g (M.f x) -type _ t = - | C: ((('a -> 'o) -> 'o) -> ('b -> 'o) -> 'o) t -let f : type a o. ((a -> o) -> o) t -> (a -> o) -> o = - fun (C) k -> k (fun x -> x) -module type T = sig type 'a t end -module Fix(T:T) = struct type r = 'r T.t as 'r end -type _ t = - | X of string - | Y: bytes t -let y : string t = Y -let f : string A.t -> unit = function | A.X s -> print_endline s -let () = f A.y -module rec A:sig type t end = - struct type t = { - a: unit ; - b: unit } - let _ = { a = () } end - -type t = [ `A | `B ] -type 'a u = t -let a : [< int u] = `A -type 'a s = 'a -let b : [< t s] = `B -module Core = - struct - module Int = - struct - module T = - struct type t = int - let compare = compare - let (+) x y = x + y end - include T - module Map = (Map.Make)(T) - end - module Std = struct module Int = Int end - end -open Core.Std -let x = Int.Map.empty -let y = x + x -module M = struct type t = - | A - type u = - | C end -module N = struct type t = - | B end -open M -open N -;;A -;;B -;;C -include M -open M -;;C -module L = struct type v = - | V end -open L -;;V -module L = struct type v = - | V end -open L -;;V -type t1 = - | A -module M1 = struct type u = v - and v = t1 end -module N1 = struct type u = v - and v = M1.v end -type t1 = - | B -module N2 = struct type u = v - and v = M1.v end -module type PR6566 = sig type t = string end -module PR6566 = struct type t = int end -module PR6566' : PR6566 = PR6566 -module A = struct module B = struct type t = - | T end end -module M2 = struct type u = A.B.t - type foo = int - type v = A.B.t end -module type VALUE = sig type value type state type usert end -module type CORE0 = - sig module V : VALUE val setglobal : V.state -> string -> V.value -> unit - end -module type CORE = - sig include CORE0 val apply : V.value -> V.state -> V.value list -> V.value - end -module type AST = - sig - module Value : VALUE - type chunk - type program - val get_value : chunk -> Value.value - end -module type EVALUATOR = - sig - module Value : VALUE - module Ast : AST with module Value := Value - type state = Value.state - type value = Value.value - exception Error of string - val compile : Ast.program -> string - include CORE0 with module V := Value - end -module type PARSER = sig type chunk val parse : string -> chunk end -module type INTERP = - sig - include EVALUATOR - module Parser : PARSER with type chunk = Ast.chunk - val dostring : state -> string -> value list - val mk : unit -> state - end -module type USERTYPE = - sig type t val eq : t -> t -> bool val to_string : t -> string end -module type TYPEVIEW = - sig type combined type t val map : ((combined -> t) * (t -> combined)) end -module type COMBINED_COMMON = - sig - module T : sig type t end - module TV1 : TYPEVIEW with type combined := T.t - module TV2 : TYPEVIEW with type combined := T.t - end -module type COMBINED_TYPE = - sig module T : USERTYPE include COMBINED_COMMON with module T := T end -module type BARECODE = sig type state val init : state -> unit end -module USERCODE(X:TYPEVIEW) = - struct - module type F = - functor (C : CORE with type V.usert = X.combined) -> - BARECODE with type state := C.V.state - end -module Weapon = struct type t end -module type WEAPON_LIB = - sig - type t = Weapon.t - module T : USERTYPE with type t = t - module Make : functor (TV : TYPEVIEW with type t = t) -> USERCODE(TV).F - end -module type X = functor (X : CORE) -> BARECODE -module type X = CORE -> BARECODE -module M = struct type t = (int * (< m: 'a > as 'a)) end -module type S = sig module M : sig type t end end with module M = M -module type Printable = - sig type t val print : Format.formatter -> t -> unit end -module type Comparable = sig type t val compare : t -> t -> int end -module type PrintableComparable = - sig include Printable include Comparable with type t = t end -module type PrintableComparable = - sig - type t - include Printable with type t := t - include Comparable with type t := t - end -module type PrintableComparable = - sig include Printable include Comparable with type t := t end -module type ComparableInt = Comparable with type t := int -module type S = sig type t val f : t -> t end -module type S' = S with type t := int -module type S = sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end -module type S1 = S with type 'a t := 'a list -module type S2 = - sig type 'a dict = (string * 'a) list include S with type 'a t := 'a dict - end -module type S = - sig module T : sig type exp type arg end val f : T.exp -> T.arg end -module M = struct type exp = string - type arg = int end -module type S' = S with module T := M -module type S = sig type 'a t end with type 'a t := unit -let property (type t) () = - let module M = struct exception E of t end in - ((fun x -> M.E x), ((function | M.E x -> Some x | _ -> None))) -let () = - let (int_inj, int_proj) = property () in - let (string_inj, string_proj) = property () in - let i = int_inj 3 in - let s = string_inj "abc" in - Printf.printf "%B\n%!" ((int_proj i) = None); - Printf.printf "%B\n%!" ((int_proj s) = None); - Printf.printf "%B\n%!" ((string_proj i) = None); - Printf.printf "%B\n%!" ((string_proj s) = None) -let sort_uniq (type s) cmp l = - let module S = (Set.Make)(struct type t = s - let compare = cmp end) in - S.elements (List.fold_right S.add l S.empty) -let () = - print_endline (String.concat "," (sort_uniq compare ["abc"; "xyz"; "abc"])) -let f x (type a) (y : a) = x = y -class ['a] c = - object (self) - method m : 'a -> 'a= fun x -> x - method n : 'a -> 'a= fun (type g) (x : g) -> self#m x - end -external a : ((int)[@untagged ]) -> unit = "a" "a_nat" -external b : ((int32)[@unboxed ]) -> unit = "b" "b_nat" -external c : ((int64)[@unboxed ]) -> unit = "c" "c_nat" -external d : ((nativeint)[@unboxed ]) -> unit = "d" "d_nat" -external e : ((float)[@unboxed ]) -> unit = "e" "e_nat" -type t = private int -external f : ((t)[@untagged ]) -> unit = "f" "f_nat" -module M : - sig - external a : int -> ((int)[@untagged ]) = "a" "a_nat" - external b : ((int)[@untagged ]) -> int = "b" "b_nat" - end = - struct - external a : int -> ((int)[@untagged ]) = "a" "a_nat" - external b : ((int)[@untagged ]) -> int = "b" "b_nat" - end -module Global_attributes = - struct - [@@@ocaml.warning "-3"] - external a : float -> float = "a" "noalloc" "a_nat" "float" - external b : float -> float = "b" "noalloc" "b_nat" - external c : float -> float = "c" "c_nat" "float" - external d : float -> float = "d" "noalloc" - external e : float -> float = "e" - external f : ((int32)[@unboxed ]) -> ((int32)[@unboxed ]) = "f" "noalloc" - external g : int32 -> int32 = "g" "g_nat"[@@unboxed ][@@noalloc ] - external h : - ((int)[@untagged ]) -> ((int)[@untagged ]) = "h" "h_nat" "noalloc" - external i : int -> int = "i" "i_nat"[@@untagged ][@@noalloc ] - end -module Old_style_warning = - struct - [@@@ocaml.warning "+3"] - external a : float -> float = "a" "noalloc" "a_nat" "float" - external b : float -> float = "b" "noalloc" "b_nat" - external c : float -> float = "c" "c_nat" "float" - external d : float -> float = "d" "noalloc" - external e : float -> float = "c" "float" - end -module Bad1 : sig external f : int -> int = "f" "f_nat" end = - struct external f : int -> ((int)[@untagged ]) = "f" "f_nat" end -module Bad2 : sig external f : int -> int = "a" "a_nat" end = - struct external f : ((int)[@untagged ]) -> int = "f" "f_nat" end -module Bad3 : sig external f : float -> float = "f" "f_nat" end = - struct external f : float -> ((float)[@unboxed ]) = "f" "f_nat" end -module Bad4 : sig external f : float -> float = "a" "a_nat" end = - struct external f : ((float)[@unboxed ]) -> float = "f" "f_nat" end -module Bad5 : sig external f : int -> ((int)[@untagged ]) = "f" "f_nat" end = - struct external f : int -> int = "f" "f_nat" end -module Bad6 : sig external f : ((int)[@untagged ]) -> int = "f" "f_nat" end = - struct external f : int -> int = "a" "a_nat" end -module Bad7 : - sig external f : float -> ((float)[@unboxed ]) = "f" "f_nat" end = - struct external f : float -> float = "f" "f_nat" end -module Bad8 : - sig external f : ((float)[@unboxed ]) -> float = "f" "f_nat" end = - struct external f : float -> float = "a" "a_nat" end -external g : ((float)[@untagged ]) -> float = "g" "g_nat" -external h : ((int)[@unboxed ]) -> float = "h" "h_nat" -external i : ((int -> float)[@unboxed ]) = "i" "i_nat" -external j : int -> (((float)[@unboxed ]) * float) = "j" "j_nat" -external k : int -> ((float)[@unboxd ]) = "k" "k_nat" -external l : float -> float = "l" "l_nat" "float"[@@unboxed ] -external m : ((float)[@unboxed ]) -> float = "m" "m_nat" "float" -external n : float -> float = "n" "noalloc"[@@noalloc ] -external o : ((float)[@unboxed ]) -> float = "o" -external p : float -> ((float)[@unboxed ]) = "p" -external q : ((int)[@untagged ]) -> float = "q" -external r : int -> ((int)[@untagged ]) = "r" -external s : int -> int = "s"[@@untagged ] -external t : float -> float = "t"[@@unboxed ] -let _ = ignore (+) -let _ = raise Exit 3 -;;fun b -> if b then format_of_string "x" else "y" -;;fun b -> if b then "x" else format_of_string "y" -;;fun b : (_, _, _) format-> if b then "x" else "y" -module PR7135 = - struct - module M : sig type t = private int end = struct type t = int end - include M - let lift2 (f : int -> int -> int) (x : t) (y : t) = - f (x :> int) (y :> int) - end -module Test1 = - struct - type t = private int - let f x = let y = if true then x else (x : t) in (y :> int) - end -let f = function | (None, None) -> 1 | (Some _, Some _) -> 2 -type _ t = - | A: int t - | B: bool t - | C: char t - | D: float t -type (_, _, _, _) u = - | U: (int, int, int, int) u -type v = - | E - | F - | G -let f : type a b c d e f g. - (a t * b t * c t * d t * e t * f t * g t * v * (a, b, c, d) u * (e, - f, g, g) u) -> int - = - function - | (A, A, A, A, A, A, A, _, U, U) -> 1 - | (_, _, _, _, _, _, _, G, _, _) -> 1 -let f (x : int t) = match x with | A -> 1 | _ -> 2 -let f (x : unit t option) = match x with | None -> 1 | _ -> 2 -let f (x : unit t option) = match x with | None -> 1 | Some _ -> 2 -let f (x : int t option) = match x with | None -> 1 | _ -> 2 -let f (x : int t option) = match x with | None -> 1 -type 'a box = - | Box of 'a -type 'a pair = { - left: 'a ; - right: 'a } -let f : (int t box pair * bool) option -> unit = function | None -> () -let f : (string t box pair * bool) option -> unit = function | None -> () -type _ t = - | Int: int t - | Bool: bool t -let f : type a. a t -> a = function | Int -> 1 | Bool -> true -let g : int t -> int = function | Int -> 1 -let h : type a. a t -> a t -> bool = - fun x y -> match (x, y) with | (Int, Int) -> true | (Bool, Bool) -> true -type (_, _) cmp = - | Eq: ('a, 'a) cmp - | Any: ('a, 'b) cmp -module A : sig type a type b val eq : (a, b) cmp end = - struct type a - type b = a - let eq = Eq end -let f : (A.a, A.b) cmp -> unit = function | Any -> () -let deep : char t option -> char = function | None -> 'c' -type zero = - | Zero -type _ succ = - | Succ -type (_, _, _) plus = - | Plus0: (zero, 'a, 'a) plus - | PlusS: ('a, 'b, 'c) plus -> ('a succ, 'b, 'c succ) plus -let trivial : (zero succ, zero, zero) plus option -> bool = - function | None -> false -let easy : (zero, zero succ, zero) plus option -> bool = - function | None -> false -let harder : (zero succ, zero succ, zero succ) plus option -> bool = - function | None -> false -let harder : (zero succ, zero succ, zero succ) plus option -> bool = - function | None -> false | Some (PlusS _) -> . -let inv_zero : type a b c d. (a, b, c) plus -> (c, d, zero) plus -> bool = - fun p1 p2 -> match (p1, p2) with | (Plus0, Plus0) -> true -type _ t = - | Int: int t -let f (x : bool t) = match x with | _ -> . -let f () = match None with | _ -> . -let g () = match None with | _ -> () | exception _ -> . -let h () = match None with | _ -> . | exception _ -> . -let f x = match x with | _ -> () | None -> . -let f x y = match 1 with | 1 when x = y -> 1 -open CamlinternalOO -type _ choice = - | Left: label choice - | Right: tag choice -let f : label choice -> bool = function | Left -> true -exception A -type a = - | A -;;A -;;raise A -;;fun (A : a) -> () -;;function | Not_found -> 1 | A -> 2 | _ -> 3 -;;try raise A with | A -> 2 -module TypEq = struct type (_, _) t = - | Eq: ('a, 'a) t end -module type T = - sig - type _ is_t = - | Is: ('a, 'b) TypEq.t -> 'a is_t - val is_t : unit -> unit is_t option - end -module Make(M:T) = - struct - let _ = match M.is_t () with | None -> 0 | Some _ -> 0 - let f () = match M.is_t () with | None -> 0 - end -module Make2(M:T) = - struct type t = - | T of unit M.is_t - let g : t -> int = function | _ -> . end -type t = - | A: t -module X1 : sig end = struct let _f ~x = function | A -> let x = () in x end -module X2 : sig end = - struct let x = 42 - let _f = function | A -> let x = () in x end -module X3 : sig end = - struct - module O = struct let x = 42 end - open O - let _f = function | A -> let x = () in x - end -module M1 = struct type t = { - x: int ; - y: int } - type u = { - x: bool ; - y: bool } end -module OK = - struct - open M1 - let f1 (r : t) = r.x - let f2 r = ignore (r : t); r.x - let f3 (r : t) = match r with | { x; y } -> y + y - end -module F1 = struct open M1 - let f r = match r with | { x; y } -> y + y end -module F2 = - struct - open M1 - let f r = ignore (r : t); (match r with | { x; y } -> y + y) - end -module M = struct type t = { - x: int } - type u = { - x: bool } end -let f (r : M.t) = r.M.x -let f (r : M.t) = r.x -let f ({ x } : M.t) = x -module M = struct type t = { - x: int ; - y: int } end -module N = struct type u = { - x: bool ; - y: bool } end -module OK = struct open M - open N - let f (r : M.t) = r.x end -module M = - struct - type t = { - x: int } - module N = struct type s = t = { - x: int } end - type u = { - x: bool } - end -module OK = struct open M.N - let f (r : M.t) = r.x end -module M = - struct type u = { - x: bool ; - y: int ; - z: char } - type t = { - x: int ; - y: bool } end -module OK = struct open M - let f { x; z } = (x, z) end -module F3 = struct open M - let r = { x = true; z = 'z' } end -module OK = - struct - type u = { - x: int ; - y: bool } - type t = { - x: bool ; - y: int ; - z: char } - let r = { x = 3; y = true } - end -module F4 = - struct - type foo = { - x: int ; - y: int } - type bar = { - x: int } - let b : bar = { x = 3; y = 4 } - end -module M = struct type foo = { - x: int ; - y: int } end -module N = struct type bar = { - x: int ; - y: int } end -let r = { M.x = 3; N.y = 4 } -module MN = struct include M - include N end -module NM = struct include N - include M end -let r = { MN.x = 3; NM.y = 4 } -module M = - struct type foo = { - x: int ; - y: int } - type bar = { - x: int ; - y: int ; - z: int } end -module F5 = - struct open M - let f r = ignore (r : foo); { r with x = 2; z = 3 } end -module M = struct include M - type other = { - a: int ; - b: int } end -module F6 = - struct open M - let f r = ignore (r : foo); { r with x = 3; a = 4 } end -module F7 = - struct open M - let r = { x = 1; y = 2 } - let r : other = { x = 1; y = 2 } end -module A = struct type t = { - x: int } end -module B = struct type t = { - x: int } end -let f (r : B.t) = r.A.x -module F8 = - struct type t = { - x: int ; - yyy: int } - let a : t = { x = 1; yyz = 2 } end -type t = - | A -type s = - | A -class f (_ : t)= object end -class g = ((f) A) -class f (_ : 'a) (_ : 'a) = object end -class g = ((f) (A : t) A) -module Shadow1 = - struct - type t = { - x: int } - module M = struct type s = { - x: string } end - open M - let y : t = { x = 0 } - end -module Shadow2 = - struct - type t = { - x: int } - module M = struct type s = { - x: string } end - open M - let y = { x = "" } - end -module P6235 = - struct - type t = { - loc: string } - type v = { - loc: string ; - x: int } - type u = [ `Key of t ] - let f (u : u) = match u with | `Key { loc } -> loc - end -module P6235' = - struct - type t = { - loc: string } - type v = { - loc: string ; - x: int } - type u = [ `Key of t ] - let f = function | (_ : u) when false -> "" | `Key { loc } -> loc - end -module Unused : sig end = struct type unused = int end -module Unused_nonrec : sig end = - struct type nonrec used = int - type nonrec unused = used end -module Unused_rec : sig end = struct type unused = - | A of unused end -module Unused_exception : sig end = struct exception Nobody_uses_me end -module Unused_extension_constructor : sig type t = .. end = - struct type t = .. - type t += - | Nobody_uses_me end -module Unused_exception_outside_patterns : sig val falsity : exn -> bool end - = - struct - exception Nobody_constructs_me - let falsity = function | Nobody_constructs_me -> true | _ -> false - end -module Unused_extension_outside_patterns : - sig type t = .. val falsity : t -> bool end = - struct - type t = .. - type t += - | Nobody_constructs_me - let falsity = function | Nobody_constructs_me -> true | _ -> false - end -module Unused_private_exception : sig type exn += private - | Private_exn end = - struct exception Private_exn end -module Unused_private_extension : - sig type t = .. type t += private - | Private_ext end = - struct type t = .. - type t += - | Private_ext end -;;for i = 10 downto 0 do () done -type t = < foo: int [@foo ] > -let _ = [%foo : < foo: t > ] -type foo += private - | A of int -let f : 'a 'b 'c . < .. > = assert false -let () = - let module M = (functor (T : sig end) -> struct end)(struct end) in () -class c = - object inherit (((fun () -> ((object end)[@wee ]) : object end)) ()) end -let f = function | ((x)[@wee ]) -> () -let f = function | '1'..'9' | '1'..'8' -> () | 'a'..'z' -> () -let f = - function | [|x1;x2|] -> () | [||] -> () | (([|x|])[@foo ]) -> () | _ -> () -let g = - function - | { l = x } -> () - | (({ l1 = x; l2 = y })[@foo ]) -> () - | { l1 = x; l2 = y;_} -> () -let h ?l:(p= 1) ?y:u ?(x= 3) = 2 -let _ = - function - | (a, s, ba1, ba2, ba3, bg) -> - (ignore ((((x.(1)) + ([||].(0))) + ([|1|].(1))) + ([|1;2|].(2))); - ignore [s.[1]; "".[2]; "123".[3]]; - ignore (((ba1.{0}) + (ba2.{1,2})) + (ba3.{3,4,5})) ignore - (bg.{1,2,3,4})) - | (b, s, ba1, ba2, ba3, bg) -> - (y.(0) <- 1; - s.![1] <- 'c'; - ba1.{1} <- 2; - ba2.{1,2} <- 3; - ba3.{1,2,3} <- 4; - bg.{1,2,3,4,5} <- 0) -let f (type t) () = - let exception F of t in - (); - (let exception G of t in - (); - (let exception E of t in - ((fun x -> E x), - (function | E _ -> print_endline "OK" | _ -> print_endline "KO")))) -let (inj1, proj1) = f () -let (inj2, proj2) = f () -let () = proj1 (inj1 42) -let () = proj1 (inj2 42) -let _ = ~- 1 -class id = [%exp ] -let _ = fun (x : < x: int > ) y z -> ((y :> 'a), (x :> 'a), (z :> 'a)) -class ['a] c ()= object method f = ((new c) () : int c) end -and ['a] d ()= object inherit ((['a] c) ()) end -let _ = - let module M = struct type t = { - x: int } end in - let f M.(x) = () in - let g M.{ x } = () in - let h = function | M.[] | M.(a::[]) | M.(a::q) -> () in - let i = function | M.[||] | M.[|x|] -> true | _ -> false in () -class ['a] c ()= - object constraint 'a = < .. > -> unit method m = (fun x -> () : 'a) end -let f : type a'. a' = assert false -let foo : type a' b'. a' -> b' = fun a -> assert false -let foo : type t'. t' = fun (type t') -> (assert false : t') -let foo : 't . 't = fun (type t) -> (assert false : t) -let foo : type a' b' c' t. a' -> b' -> c' -> t = fun a b c -> assert false -let f x = x.contents <- (print_string "coucou"; x.contents) -let (~$) x = Some x -let g x = ~$ (x.contents) -let (~$) x y = (x, y) -let g x y = (~$ (x.contents)) y.contents -let tail1 = (([1; 2])[@hello ]) -let tail2 = 0 :: (([1; 2])[@hello ]) -let tail3 = 0 :: (([])[@hello ]) -let f ~l:((l)[@foo ]) = l -let test x y = (((+))[@foo ]) x y -let test x = (((~-))[@foo ]) x -let test contents = { contents = ((contents)[@foo ]) } -class type t = object (((_)[@foo ])) end -let test f x = f ~x:((x)[@foo ]) -let f = function | ((`A | `B)[@bar ]) | `C -> () -let f = function | _::((_::_)[@foo ]) -> () | _ -> () -;;function | { contents = ((contents)[@foo ]) } -> () -;;fun contents -> { contents = ((contents)[@foo ]) } -;;(); ((((); ()))[@foo ]) -let () = (foo ##. bar) := () -class c = let open M in object method f : t= x end -class type ct = let open M in object method f : t end -module Exotic_list = - struct - module Inner = - struct type ('a, 'b) t = - | [] - | (::) of 'a * 'b * ('a, 'b) t end - let Inner.(::) (x, y, Inner.[] ) = - Inner.(::) (1, "one", (let open Inner in [])) - end -module Indexop = - struct - module Def = - struct - let (.%[]) = Hashtbl.find - let (.%[]<-) = Hashtbl.add - let (.%()) = Hashtbl.find - let (.%()<-) = Hashtbl.add - let (.%{}) = Hashtbl.find - let (.%{}<-) = Hashtbl.add - end - ;;let h = Hashtbl.create 17 in - h.Def.%["one"] <- 1; h.Def.%("two") <- 2; h.Def.%{"three"} <- 3 - let (x, y, z) = - let open Def in ((h.%["one"]), (h.%("two")), (h.%{"three"})) - end[@@ocaml.doc " Extended index operators "] -type t = | -let x = `Foo -let x = `Bar -type (+'a, -' a', ' a'b', 'ab', 'abcd', 'x) t = - ('a * ' a' * ' a'b' * 'ab' * 'abcd' * 'x) as ' a' -let f = function | (lazy (A foo)) -> foo -let () = f (fun (type t) -> x) -type t = unit -let rec equal : 'a . ('a -> 'a -> bool) -> 'a t -> 'a t -> bool = - ((fun poly_a (_ : unit) (_ : unit) -> true)[@ocaml.warning "-A"])[@@ocaml.warning - "-39"] -type u = [ `A ] -type v = [ | u | `B ] -let f (x : [ | u]) = x -let test = function | `A | `B as x -> ignore x -let test = function | (`A as x) | (`B as x) -> ignore x -let test = function | (`A as x) | (`B as x) as z -> ignore (z, x) -let test = function | (`A as x) | (`B as x) as z -> ignore (z, x) -let test = function | `A | `B | `C -> () -let test = function | `A | (`B | `C) -> () -let test = function | `A | `B | `C -> () -let test = function | (`A | `B as x) | `C -> () -let g y = let f ~y = y + 1 in f ~y:(y : int) -module M = - struct - let ( let* ) x f = f x - let ( and* ) a b = (a, b) - let x = 1 - and y = 2 - and z = 3 - let p = let* x - and* y - and* z in (x, y, z) - let q = [%foo let x = x - and y = y - and z = z in (x, y, z)] - end -let x = object method f = 1 end -let x = (object method f = 1 end)#f -let x = Some (object method f = 1 end) -let x = Some ((object method f = 1 end)#f) -;;let f x y z = x in - f (object method f = 1 end) (object method f = 1 end)#f (object end) -let g y = let f ~y = y + 1 in f ~y:(y : int) -let goober a = match a with | C (type a b) y -> y -[@@@ocaml.text " With constraints "] -module type s = - sig type ('a, 'b) t end with type (-!'a, +!'b) t = 'b -> 'a list -module type s = - sig type ('a, 'b) t end with type (-!'a, +!'b) t := 'b -> 'a list -module type s = - sig type ('a, 'b) t end with type ('a, 'b) t := 'b -> 'a list -let x :[ `A ] :> [> `A | `B ] = `A -let x :> [> `A | `B ] = `A -module type A = - sig - type ('\#let, 'a) \#virtual = ('\#let * 'a) as '\#mutable - val foo : '\#let 'a . 'a -> '\#let -> unit - type foo = { - \#let: int } - end -module M = - struct - let (\#let, foo) as \#val = (\#mutable, baz) - let _ = fun (type let) (type foo) -> 1 - let f g ~\#let ?\#and ?(\#for= \#and) () = g ~\#let ?\#and () - class \#let = object inherit ((\#val) \#let) as \#mutable end - end -let x = new M.\#begin -let f x (type begin) (type end) = 1 -type t = String.(t) -let x :[ `A ] :> [> `A | `B ] = `A -let x :> [> `A | `B ] = `A - -===================================================== From 8cb65cbfb2d543e883dd7557a082b60974e4cd6d Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 10 Sep 2024 12:52:47 +0100 Subject: [PATCH 38/76] Fix chamelon --- chamelon/minimizer/flatteningmodules.ml | 6 ++++++ chamelon/minimizer/removedeadcode.ml | 13 +++++++++++++ 2 files changed, 19 insertions(+) diff --git a/chamelon/minimizer/flatteningmodules.ml b/chamelon/minimizer/flatteningmodules.ml index 9fc77221698..7500805f0e5 100644 --- a/chamelon/minimizer/flatteningmodules.ml +++ b/chamelon/minimizer/flatteningmodules.ml @@ -86,6 +86,12 @@ let rec replace_in_pat : type k. _ -> k general_pattern -> k general_pattern = { str with txt = mod_name ^ "_" ^ str.txt } ) | Tpat_tuple (vl, id) -> mkTpat_tuple ~id (List.map (replace_in_pat mod_name) vl) + | O (Tpat_unboxed_tuple fields) -> + Tpat_unboxed_tuple + (List.map + (fun (name, pat, sort) -> + (name, replace_in_pat mod_name pat, sort)) + fields) | Tpat_array (vl, id) -> mkTpat_array ~id (List.map (replace_in_pat mod_name) vl) | O (Tpat_construct (a1, a2, vl, a3)) -> diff --git a/chamelon/minimizer/removedeadcode.ml b/chamelon/minimizer/removedeadcode.ml index c5dce307255..676f4c0c6d4 100644 --- a/chamelon/minimizer/removedeadcode.ml +++ b/chamelon/minimizer/removedeadcode.ml @@ -78,6 +78,11 @@ let rec var_from_pat pat_desc acc = | Tpat_tuple (vl, _) | Tpat_array (vl, _) | O (Tpat_construct (_, _, vl, _)) -> List.fold_left (fun l pat -> var_from_pat pat.pat_desc l) acc vl + | O (Tpat_unboxed_tuple fields) -> + List.fold_left + (fun l pat -> var_from_pat pat.pat_desc l) + acc + (List.map (fun (_, pat, _) -> pat) fields) | O (Tpat_record (r, _)) -> List.fold_left (fun l (_, _, pat) -> var_from_pat pat.pat_desc l) acc r | O (Tpat_or (p1, p2, _)) -> @@ -109,6 +114,14 @@ let rec rem_in_pat str pat should_remove = mkTpat_tuple ~id (List.map (fun pat -> rem_in_pat str pat should_remove) vl); } + | O (Tpat_unboxed_tuple fields) -> + let fields' = + List.map + (fun (name, pat, sort) -> + (name, rem_in_pat str pat should_remove, sort)) + fields + in + { pat with pat_desc = Tpat_unboxed_tuple fields' } | Tpat_array (vl, id) -> { pat with From caebc8adff25cdb64ebd2e52c97e6863e29fbb6c Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Wed, 11 Sep 2024 12:20:27 +0100 Subject: [PATCH 39/76] Fix bug with update_field and mixed blocks (#3028) --- middle_end/flambda2/to_cmm/to_cmm_static.ml | 40 ++++++++++++++++--- .../mixed-blocks/structural_constants.ml | 11 ++++- 2 files changed, 44 insertions(+), 7 deletions(-) diff --git a/middle_end/flambda2/to_cmm/to_cmm_static.ml b/middle_end/flambda2/to_cmm/to_cmm_static.ml index 9886f7efa88..30cb65d782f 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_static.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_static.ml @@ -35,22 +35,22 @@ let or_variable f default v cont = | Const c -> f c cont | Var _ -> f default cont -let update_field symb env res acc i field = +let update_field symb env res acc i update_kind field = Simple.pattern_match' (Simple.With_debuginfo.simple field) ~var:(fun var ~coercion:_ -> (* CR mshinwell/mslater: It would be nice to know if [var] is an immediate. *) let dbg = Simple.With_debuginfo.dbg field in - C.make_update env res dbg UK.pointers ~symbol:(C.symbol ~dbg symb) var + C.make_update env res dbg update_kind ~symbol:(C.symbol ~dbg symb) var ~index:i ~prev_updates:acc) ~symbol:(fun _sym ~coercion:_ -> env, res, acc) ~const:(fun _cst -> env, res, acc) let rec static_block_updates symb env res acc i = function | [] -> env, res, acc - | sv :: r -> - let env, res, acc = update_field symb env res acc i sv in + | (simple, update_kind) :: r -> + let env, res, acc = update_field symb env res acc i update_kind simple in static_block_updates symb env res acc (i + 1) r type maybe_int32 = @@ -231,7 +231,31 @@ let static_const0 env res ~updates (bound_static : Bound_static.Pattern.t) in let static_fields = List.concat_map (static_field res) fields in let block = C.emit_block sym header static_fields in - let env, res, updates = static_block_updates sym env res updates 0 fields in + let update_kinds = + match shape with + | Value_only -> List.map (fun _ -> UK.pointers) fields + | Mixed_record shape -> + let value_prefix = + List.init (Flambda_kind.Mixed_block_shape.value_prefix_size shape) + (fun _ -> UK.pointers) + in + let flat_suffix = + List.map + (fun (flat_suffix_elt : Flambda_kind.flat_suffix_element) -> + match flat_suffix_elt with + | Tagged_immediate -> UK.tagged_immediates + | Naked_float -> UK.naked_floats + | Naked_float32 -> UK.naked_float32_fields + | Naked_int32 -> UK.naked_int32_fields + | Naked_int64 | Naked_nativeint -> UK.naked_int64s) + (Flambda_kind.Mixed_block_shape.flat_suffix shape |> Array.to_list) + in + value_prefix @ flat_suffix + in + let env, res, updates = + static_block_updates sym env res updates 0 + (List.combine fields update_kinds) + in env, R.set_data res block, updates | Set_of_closures closure_symbols, Set_of_closures set_of_closures -> let res, updates, env = @@ -332,7 +356,11 @@ let static_const0 env res ~updates (bound_static : Bound_static.Pattern.t) let header = C.black_block_header 0 (List.length fields) in let static_fields = List.concat_map (static_field res) fields in let block = C.emit_block sym header static_fields in - let env, res, updates = static_block_updates sym env res updates 0 fields in + let update_kinds = List.map (fun _ -> UK.pointers) fields in + let env, res, updates = + static_block_updates sym env res updates 0 + (List.combine fields update_kinds) + in env, R.set_data res block, updates | Block_like s, Empty_array Values_or_immediates_or_naked_floats -> (* Recall: empty arrays have tag zero, even if their kind is naked float. *) diff --git a/ocaml/testsuite/tests/mixed-blocks/structural_constants.ml b/ocaml/testsuite/tests/mixed-blocks/structural_constants.ml index c6f409d5204..d5d68821bac 100644 --- a/ocaml/testsuite/tests/mixed-blocks/structural_constants.ml +++ b/ocaml/testsuite/tests/mixed-blocks/structural_constants.ml @@ -13,6 +13,7 @@ type v = | B of string * float# | C of string * float# * int | D of string + | E of int * int32# * int64# * nativeint# let r1 = { x1 = "x1"; y1 = #1.0 } let create_r1 () = { x1 = "x1"; y1 = #1.0 } @@ -63,8 +64,16 @@ let () = let s = Sys.opaque_identity "foo" in let bytes_start0 = Gc.allocated_bytes () in let bytes_start1 = Gc.allocated_bytes () in + (* These variables ensure that we test the [make_update] code for + static inconstant blocks. *) + let imm = Sys.opaque_identity 42 in + let i32 = Sys.opaque_identity #3l in + let i64 = Sys.opaque_identity #4L in + let nat = Sys.opaque_identity #5n in + let f = Sys.opaque_identity #6. in let _ = - Sys.opaque_identity [A #4.0; B ("B", #5.0); C ("C", #6.0, 6); D s] + Sys.opaque_identity [A #4.0; B ("B", #5.0); C ("C", f, 6); D s; + E (imm, i32, i64, nat)] in match Sys.backend_type with | Bytecode -> () From 63c0c22549a8fb9ba621165bb749d1f84d8d296d Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Wed, 11 Sep 2024 13:38:44 +0100 Subject: [PATCH 40/76] Update ocaml/utils/misc.ml Co-authored-by: Xavier Clerc --- ocaml/utils/misc.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ocaml/utils/misc.ml b/ocaml/utils/misc.ml index bc4c23b3211..493cbc88c39 100644 --- a/ocaml/utils/misc.ml +++ b/ocaml/utils/misc.ml @@ -1344,7 +1344,7 @@ module Magic_number = struct | Cmo -> "bytecode object file" | Cma -> "bytecode library" | Cmx -> "native compilation unit description" - | Cmxa -> "static native library (%s)" + | Cmxa -> "static native library" | Cmxs -> "dynamic native library" | Cmt -> "compiled typedtree file" | Cms -> "compiled shape file" From c308b8f931934a142f05782b8b702cad68fba094 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Wed, 11 Sep 2024 14:35:33 +0100 Subject: [PATCH 41/76] Enable poll insertion for flambda2_o3_advanced_meet_frame_pointers_runtime5_polling --- .github/workflows/build.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index d22e418948c..b6d305b1962 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -54,8 +54,8 @@ jobs: build_ocamlparam: '' ocamlparam: '_,O3=1' - - name: flambda2_o3_advanced_meet_frame_pointers_runtime5 - config: --enable-middle-end=flambda2 --enable-frame-pointers --enable-runtime5 + - name: flambda2_o3_advanced_meet_frame_pointers_runtime5_polling + config: --enable-middle-end=flambda2 --enable-frame-pointers --enable-runtime5 --enable-poll-insertion os: ubuntu-latest build_ocamlparam: '' ocamlparam: '_,O3=1,flambda2-meet-algorithm=advanced' From c4958d1f71eb198efc39f69cc716a1a734704040 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Wed, 11 Sep 2024 14:36:07 +0100 Subject: [PATCH 42/76] Rename to flambda2_frame_pointers_oclassic_polling --- .github/workflows/build.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index b6d305b1962..89a6d5abd4f 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -67,7 +67,7 @@ jobs: use_runtime: d ocamlparam: '_,O3=1,flambda2-meet-algorithm=advanced' - - name: flambda2_frame_pointers_oclassic + - name: flambda2_frame_pointers_oclassic_polling config: --enable-middle-end=flambda2 --enable-frame-pointers --enable-poll-insertion os: ubuntu-latest build_ocamlparam: '' From b2e30f92a89fff657782be5db50c236222e76eeb Mon Sep 17 00:00:00 2001 From: Milan Tom <48379919+milan-tom@users.noreply.github.com> Date: Thu, 12 Sep 2024 17:09:40 +0100 Subject: [PATCH 43/76] Add directory and file annotation to profile output (#3031) * Annotate filenames in profile output with directory (if passed in) and `file=` * Change separator after filename to `//` for profile csv output (to distinguish between backslashes used for delimiters for pass names and those used in file) * Sanitise function names using `X86_proc.string_of_symbol` * Add column for file in summary csv * Annotate linked files with `file=` * Update counter test references --- backend/asmgen.ml | 3 +- backend/asmlink.ml | 4 +-- ocaml/asmcomp/asmlink.ml | 4 +-- ocaml/driver/compile_common.ml | 4 +-- .../ml_counters.ocamlc.reference | 2 +- .../mli_counters.ocamlc.reference | 2 +- .../ml_counters.ocamlc.reference | 2 +- .../ml_counters.ocamlc.reference | 2 +- .../mli_counters.ocamlc.reference | 2 +- .../ml_counters.ocamlc.reference | 2 +- .../mli_counters.ocamlc.reference | 2 +- .../ml_counters.ocamlc.reference | 2 +- .../mli_counters.ocamlc.reference | 2 +- .../ml_counters.ocamlc.reference | 2 +- .../mli_counters.ocamlc.reference | 2 +- .../nested/ml_counters.ocamlc.reference | 2 +- .../nested/mli_counters.ocamlc.reference | 2 +- ocaml/utils/profile.ml | 35 +++++++++++++------ ocaml/utils/profile.mli | 8 ++--- scripts/combine-profile-information.py | 26 +++++++++++--- 20 files changed, 71 insertions(+), 39 deletions(-) diff --git a/backend/asmgen.ml b/backend/asmgen.ml index 9bdef0d0d71..9234f3712bc 100644 --- a/backend/asmgen.ml +++ b/backend/asmgen.ml @@ -573,7 +573,8 @@ let compile_phrases ~ppf_dump ps = let profile_wrapper = match !profile_granularity with | Function_level | Block_level -> - Profile.record ~accumulate:true ("function=" ^ fd.fun_name.sym_name) + Profile.record ~accumulate:true + ("function=" ^ X86_proc.string_of_symbol "" fd.fun_name.sym_name) | File_level -> Fun.id in profile_wrapper (compile_fundecl ~ppf_dump ~funcnames) fd; diff --git a/backend/asmlink.ml b/backend/asmlink.ml index 56f8ecc3c00..3dd24075966 100644 --- a/backend/asmlink.ml +++ b/backend/asmlink.ml @@ -435,7 +435,7 @@ let call_linker_shared ?(native_toplevel = false) file_list output_name = then raise(Error(Linking_error exitcode)) let link_shared unix ~ppf_dump objfiles output_name = - Profile.record_call output_name (fun () -> + Profile.(record_call (annotate_file_name output_name)) (fun () -> if !Flambda_backend_flags.use_cached_generic_functions then (* When doing shared linking do not use the shared generated startup file. Frametables for the imported functions needs to be initialized, which is a bit @@ -522,7 +522,7 @@ let reset () = let link unix ~ppf_dump objfiles output_name = if !Flambda_backend_flags.internal_assembler then Emitaux.binary_backend_available := true; - Profile.record_call output_name (fun () -> + Profile.(record_call (annotate_file_name output_name)) (fun () -> let stdlib = "stdlib.cmxa" in let stdexit = "std_exit.cmx" in let objfiles = diff --git a/ocaml/asmcomp/asmlink.ml b/ocaml/asmcomp/asmlink.ml index 4d64457fb36..4192000c742 100644 --- a/ocaml/asmcomp/asmlink.ml +++ b/ocaml/asmcomp/asmlink.ml @@ -328,7 +328,7 @@ let call_linker_shared file_list output_name = then raise(Error(Linking_error exitcode)) let link_shared ~ppf_dump objfiles output_name = - Profile.record_call output_name (fun () -> + Profile.(record_call (annotate_filename output_name)) (fun () -> let obj_infos = List.map read_file objfiles in let units_tolink = List.fold_right scan_file obj_infos [] in List.iter @@ -381,7 +381,7 @@ let call_linker file_list startup_file output_name = (* Main entry point *) let link ~ppf_dump objfiles output_name = - Profile.record_call output_name (fun () -> + Profile.(record_call (annotate_filename output_name)) (fun () -> let stdlib = "stdlib.cmxa" in let stdexit = "std_exit.cmx" in let objfiles = diff --git a/ocaml/driver/compile_common.ml b/ocaml/driver/compile_common.ml index 6449454c5bb..88d58bdd08b 100644 --- a/ocaml/driver/compile_common.ml +++ b/ocaml/driver/compile_common.ml @@ -108,7 +108,7 @@ let emit_signature info ast tsg = info.output_prefix info.source_file info.env sg let interface ~hook_parse_tree ~hook_typed_tree info = - Profile.record_call info.source_file @@ fun () -> + Profile.(record_call (annotate_file_name info.source_file)) @@ fun () -> let ast = parse_intf info in hook_parse_tree ast; if Clflags.(should_stop_after Compiler_pass.Parsing) then () else begin @@ -144,7 +144,7 @@ let typecheck_impl i parsetree = (fun fmt {Typedtree.shape; _} -> Shape.print fmt shape) let implementation ~hook_parse_tree ~hook_typed_tree info ~backend = - Profile.record_call info.source_file @@ fun () -> + Profile.(record_call (annotate_file_name info.source_file)) @@ fun () -> let exceptionally () = let sufs = if info.native then [ cmx; obj ] else [ cmo ] in List.iter (fun suf -> remove_file (suf info)) sufs; diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/ml_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/ml_counters.ocamlc.reference index 814d710a4f9..1f5fef10c03 100644 --- a/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/ml_counters.ocamlc.reference +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/ml_counters.ocamlc.reference @@ -1,2 +1,2 @@ - comprehensions/ml_counters.ml + file=comprehensions/ml_counters.ml [comprehensions = 8; immutable_arrays = 0; include_functor = 0; labeled_tuples = 0; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/mli_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/mli_counters.ocamlc.reference index 64a4ff55404..43cdfd981d7 100644 --- a/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/mli_counters.ocamlc.reference +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/comprehensions/mli_counters.ocamlc.reference @@ -1,2 +1,2 @@ - comprehensions/mli_counters.mli + file=comprehensions/mli_counters.mli [comprehensions = 0; immutable_arrays = 0; include_functor = 0; labeled_tuples = 0; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_array_comprehensions/ml_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_array_comprehensions/ml_counters.ocamlc.reference index 9f9e1c65ae3..d931914f5e0 100644 --- a/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_array_comprehensions/ml_counters.ocamlc.reference +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_array_comprehensions/ml_counters.ocamlc.reference @@ -1,2 +1,2 @@ - immutable_array_comprehensions/ml_counters.ml + file=immutable_array_comprehensions/ml_counters.ml [comprehensions = 4; immutable_arrays = 4; include_functor = 0; labeled_tuples = 0; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/ml_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/ml_counters.ocamlc.reference index 7fb7d4a72cd..7285f54366c 100644 --- a/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/ml_counters.ocamlc.reference +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/ml_counters.ocamlc.reference @@ -1,2 +1,2 @@ - immutable_arrays/ml_counters.ml + file=immutable_arrays/ml_counters.ml [comprehensions = 0; immutable_arrays = 8; include_functor = 0; labeled_tuples = 0; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/mli_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/mli_counters.ocamlc.reference index a9cec28b4ad..9778fd8316c 100644 --- a/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/mli_counters.ocamlc.reference +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/immutable_arrays/mli_counters.ocamlc.reference @@ -1,2 +1,2 @@ - immutable_arrays/mli_counters.mli + file=immutable_arrays/mli_counters.mli [comprehensions = 0; immutable_arrays = 3; include_functor = 0; labeled_tuples = 0; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/ml_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/ml_counters.ocamlc.reference index e8f7df3c3eb..e95ad304fb7 100644 --- a/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/ml_counters.ocamlc.reference +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/ml_counters.ocamlc.reference @@ -1,2 +1,2 @@ - include_functor/ml_counters.ml + file=include_functor/ml_counters.ml [comprehensions = 0; immutable_arrays = 0; include_functor = 6; labeled_tuples = 0; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/mli_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/mli_counters.ocamlc.reference index 063679817dc..396868a73f0 100644 --- a/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/mli_counters.ocamlc.reference +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/include_functor/mli_counters.ocamlc.reference @@ -1,2 +1,2 @@ - include_functor/mli_counters.mli + file=include_functor/mli_counters.mli [comprehensions = 0; immutable_arrays = 0; include_functor = 1; labeled_tuples = 0; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/ml_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/ml_counters.ocamlc.reference index 93aeccd2c3f..babf3e26d38 100644 --- a/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/ml_counters.ocamlc.reference +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/ml_counters.ocamlc.reference @@ -1,2 +1,2 @@ - labeled_tuples/ml_counters.ml + file=labeled_tuples/ml_counters.ml [comprehensions = 0; immutable_arrays = 0; include_functor = 0; labeled_tuples = 4; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/mli_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/mli_counters.ocamlc.reference index b73d9670a7f..7f3349b3011 100644 --- a/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/mli_counters.ocamlc.reference +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/labeled_tuples/mli_counters.ocamlc.reference @@ -1,2 +1,2 @@ - labeled_tuples/mli_counters.mli + file=labeled_tuples/mli_counters.mli [comprehensions = 0; immutable_arrays = 0; include_functor = 0; labeled_tuples = 2; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/ml_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/ml_counters.ocamlc.reference index 680c041e33c..17a6e125b84 100644 --- a/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/ml_counters.ocamlc.reference +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/ml_counters.ocamlc.reference @@ -1,2 +1,2 @@ - module_strengthening/ml_counters.ml + file=module_strengthening/ml_counters.ml [comprehensions = 0; immutable_arrays = 0; include_functor = 0; labeled_tuples = 0; module_strengthening = 1] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/mli_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/mli_counters.ocamlc.reference index f6dae797ef4..70a8a2caedb 100644 --- a/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/mli_counters.ocamlc.reference +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/module_strengthening/mli_counters.ocamlc.reference @@ -1,2 +1,2 @@ - module_strengthening/mli_counters.mli + file=module_strengthening/mli_counters.mli [comprehensions = 0; immutable_arrays = 0; include_functor = 0; labeled_tuples = 0; module_strengthening = 1] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/nested/ml_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/nested/ml_counters.ocamlc.reference index 610fc01f33b..dc658ddb670 100644 --- a/ocaml/testsuite/tests/profile/counters/language_extensions/nested/ml_counters.ocamlc.reference +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/nested/ml_counters.ocamlc.reference @@ -1,2 +1,2 @@ - nested/ml_counters.ml + file=nested/ml_counters.ml [comprehensions = 3; immutable_arrays = 0; include_functor = 0; labeled_tuples = 1; module_strengthening = 0] typing diff --git a/ocaml/testsuite/tests/profile/counters/language_extensions/nested/mli_counters.ocamlc.reference b/ocaml/testsuite/tests/profile/counters/language_extensions/nested/mli_counters.ocamlc.reference index 5ce740eb0b1..ff59af5d0a6 100644 --- a/ocaml/testsuite/tests/profile/counters/language_extensions/nested/mli_counters.ocamlc.reference +++ b/ocaml/testsuite/tests/profile/counters/language_extensions/nested/mli_counters.ocamlc.reference @@ -1,2 +1,2 @@ - nested/mli_counters.mli + file=nested/mli_counters.mli [comprehensions = 0; immutable_arrays = 1; include_functor = 0; labeled_tuples = 3; module_strengthening = 0] typing diff --git a/ocaml/utils/profile.ml b/ocaml/utils/profile.ml index 51ddca7ecec..b4a8872f84f 100644 --- a/ocaml/utils/profile.ml +++ b/ocaml/utils/profile.ml @@ -148,6 +148,16 @@ let record ?accumulate pass f x = record_call ?accumulate pass (fun () -> f x) let record_with_counters ?accumulate ~counter_f pass f x = record_call_internal ?accumulate ~counter_f pass (fun () -> f x) +let file_prefix = "file=" + +let annotate_file_name name = + let file_path = + match !Clflags.directory with + | Some directory -> Filename.concat directory name + | None -> name + in + file_prefix ^ file_path + type display = { to_string : max:float -> width:int -> string; worth_displaying : max:float -> bool; @@ -398,22 +408,27 @@ let column_mapping = [ `Counters, "counters" ] -let sanitise_for_csv = - String.map (fun c -> if Char.equal c ',' then '_' else c) - let output_to_csv ppf columns = + let sanitise_for_csv = + String.map (fun c -> if Char.equal c ',' then '_' else c) in let to_csv cell_strings = cell_strings |> List.map sanitise_for_csv |> String.concat "," in let string_columns = List.map (fun col -> List.assoc col column_mapping) columns in Format.fprintf ppf "%s@\n" (to_csv ("pass name" :: string_columns)); - let output_row_f = output_rows - ~output_row:(fun ~prefix ~cell_strings ~name -> - Format.fprintf ppf "%s@\n" (to_csv ((prefix ^ name) :: cell_strings))) - ~new_prefix:(fun ~prev ~curr_name -> Format.sprintf "%s%s/" prev curr_name) - ~always_output_ancestors:false - ~pad_empty:false - in output_columns output_row_f columns + let add_suffix pass = + let suffix = if String.starts_with ~prefix:file_prefix pass then "/" else "" in + pass ^ suffix + in + let output_row_f = + output_rows + ~output_row:(fun ~prefix ~cell_strings ~name -> + Format.fprintf ppf "%s@\n" (to_csv ((prefix ^ add_suffix name) :: cell_strings))) + ~new_prefix:(fun ~prev ~curr_name -> + Format.sprintf "%s%s/" prev (add_suffix curr_name)) + ~always_output_ancestors:false ~pad_empty:false + in + output_columns output_row_f columns let all_columns = List.map fst column_mapping let column_names = List.map snd column_mapping diff --git a/ocaml/utils/profile.mli b/ocaml/utils/profile.mli index 0785c2e18f7..5e060eec00a 100644 --- a/ocaml/utils/profile.mli +++ b/ocaml/utils/profile.mli @@ -54,14 +54,12 @@ val record_with_counters : (** [record_with_counters counter_f pass f arg] records the profile information of [f arg] and records counter information given by calling [counter_f] on the result of [f arg] *) +val annotate_file_name : string -> string +(** Annotates profiling pass for file names. *) + val print : Format.formatter -> Clflags.profile_column list -> timings_precision:int -> unit (** Prints the selected recorded profiling information to the formatter. *) -(* CR mitom: Exported for use with external tools to create dynamic counters *) -val sanitise_for_csv : string -> string -(** Sanitises a given string such that it is suitable to be used as a field in outputted - CSV files *) - val output_to_csv : Format.formatter -> Clflags.profile_column list -> timings_precision:int -> unit (** Outputs the selected recorded profiling information in CSV format to the formatter. *) diff --git a/scripts/combine-profile-information.py b/scripts/combine-profile-information.py index b474cd6a648..372a99a7377 100644 --- a/scripts/combine-profile-information.py +++ b/scripts/combine-profile-information.py @@ -5,6 +5,7 @@ from argparse import ArgumentParser import csv +import re from pathlib import Path from string import digits from typing import Dict, Iterable, Iterator, List, Tuple, Union @@ -35,6 +36,11 @@ def parse_counters(counters: str) -> Dict[str, str]: return dict(map(lambda x: tuple(x.split(" = ")), split_counters)) +def get_csv_fieldnames(csv_path: Path) -> CsvRows: + with open(csv_path) as csv_file: + return csv.DictReader(csv_file).fieldnames + + def get_csv_rows(csv_path: Path) -> CsvRows: with open(csv_path) as csv_file: csv_reader = csv.DictReader(csv_file) @@ -57,6 +63,7 @@ def split_into_number_and_unit(number_string: str) -> (Union[int, float], str): return number, unit +FILE_KEY = "file" PRIMARY_KEY = "pass name" COUNTERS_FIELD = "counters" summary_non_counter_fields = set() @@ -64,12 +71,12 @@ def split_into_number_and_unit(number_string: str) -> (Union[int, float], str): # Retrieve non-counter and counter field names selected dynamically from CSV files (also # asserts that all CSV files should have primary key and counters fields) -for rows in map(get_csv_rows, get_input_csv_paths()): - fields = set(rows[0]) +for csv_path in get_input_csv_paths(): + fields = get_csv_fieldnames(csv_path) assert PRIMARY_KEY in fields assert COUNTERS_FIELD in fields - for row in rows: + for row in get_csv_rows(csv_path): summary_counter_fields.update(parse_counters(row[COUNTERS_FIELD])) fields.remove(PRIMARY_KEY) @@ -84,7 +91,7 @@ def split_into_number_and_unit(number_string: str) -> (Union[int, float], str): } # Ensure consistent ordering of summary fields -field_collections = {PRIMARY_KEY}, summary_non_counter_fields, summary_counter_fields +field_collections = {FILE_KEY, PRIMARY_KEY}, summary_non_counter_fields, summary_counter_fields SUMMARY_FIELD_NAMES = sum(map(lambda fields: sorted(fields), field_collections), []) units = {} @@ -97,8 +104,19 @@ def strip_units(row: CsvRow) -> CsvRow: return {k: (v[: -len(units[k])] if k in units else v) for k, v in row.items()} +def add_file_to_row(row: CsvRow) -> CsvRow: + pass_name = row[PRIMARY_KEY] + file_match = re.search("/?file=(.*)//.*", pass_name) + if file_match is not None: + row[FILE_KEY] = file_match.group(1) + row[PRIMARY_KEY] = re.sub("/?file=.*//", "", pass_name) + else: + row[FILE_KEY] = "" + + def row_summary(row: CsvRow) -> SummaryRow: full_summary = {**strip_units(row), **parse_counters(row["counters"])} + add_file_to_row(full_summary) return {k: v for k, v in full_summary.items() if k in SUMMARY_FIELD_NAMES} From ae22b9a2f973f25c10d1955e1d2ae0bd76e0dc8b Mon Sep 17 00:00:00 2001 From: Zesen Qian Date: Mon, 16 Sep 2024 18:05:43 +0100 Subject: [PATCH 44/76] Fix `unique_barrier` assertion (#3038) --- ocaml/testsuite/tests/typing-unique/pr3038.ml | 19 +++++++++++++++++++ ocaml/typing/typedtree.ml | 2 +- ocaml/typing/typedtree.mli | 12 ++++++------ ocaml/typing/uniqueness_analysis.ml | 19 ++++++++----------- 4 files changed, 34 insertions(+), 18 deletions(-) create mode 100644 ocaml/testsuite/tests/typing-unique/pr3038.ml diff --git a/ocaml/testsuite/tests/typing-unique/pr3038.ml b/ocaml/testsuite/tests/typing-unique/pr3038.ml new file mode 100644 index 00000000000..1109db7f693 --- /dev/null +++ b/ocaml/testsuite/tests/typing-unique/pr3038.ml @@ -0,0 +1,19 @@ +(* TEST + readonly_files = "pr3038.ml"; +setup-ocamlc.byte-build-env; +module = "pr3038.ml"; +ocamlc.byte; +check-ocamlc.byte-output; +*) + +type r = {a : string} +type t = + | Foo of r + | Bar of r + +let f _ = () + +let foo t = + match t with + | Foo x | Bar x -> + let _ = x.a in f x diff --git a/ocaml/typing/typedtree.ml b/ocaml/typing/typedtree.ml index d6f52369550..06988227369 100644 --- a/ocaml/typing/typedtree.ml +++ b/ocaml/typing/typedtree.ml @@ -50,7 +50,7 @@ type _ pattern_category = | Value : value pattern_category | Computation : computation pattern_category -type unique_barrier = Mode.Uniqueness.r option +type unique_barrier = Mode.Uniqueness.r type unique_use = Mode.Uniqueness.r * Mode.Linearity.l diff --git a/ocaml/typing/typedtree.mli b/ocaml/typing/typedtree.mli index 373bd14791b..a203f92d916 100644 --- a/ocaml/typing/typedtree.mli +++ b/ocaml/typing/typedtree.mli @@ -63,12 +63,12 @@ type _ pattern_category = | Value : value pattern_category | Computation : computation pattern_category -(* The following will be used in the future when overwriting is introduced and - code-motion need to be checked. This will be associated to each field - projection, and represents the usage of the record immediately after this - projection. If it points to unique, that means this projection must be - borrowed and cannot be moved *) -type unique_barrier = Mode.Uniqueness.r option +(* CR zqian: use this field when overwriting is supported. *) +(** Access mode for a field projection, represented by the usage of the record + immediately following the projection. If the following usage is unique, the + projection must be borrowed and cannot be moved. If the following usage is + shared, the projection can be shared and moved. *) +type unique_barrier = Mode.Uniqueness.r type unique_use = Mode.Uniqueness.r * Mode.Linearity.l diff --git a/ocaml/typing/uniqueness_analysis.ml b/ocaml/typing/uniqueness_analysis.ml index 898209789be..2e9492b70ea 100644 --- a/ocaml/typing/uniqueness_analysis.ml +++ b/ocaml/typing/uniqueness_analysis.ml @@ -121,12 +121,12 @@ module Maybe_shared : sig (** Extract an arbitrary occurrence from the usage *) val extract_occurrence_access : t -> Occurrence.t * access - (** set a barrier. The uniqueness mode represents the usage immediately + (** Add a barrier. The uniqueness mode represents the usage immediately following the current usage. If that mode is Unique, the current usage must be Borrowed (hence no code motion); if that mode is not restricted - to Unique, this usage can be Borrowed or Shared (prefered). Raise if - called more than once. *) - val set_barrier : t -> Uniqueness.r -> unit + to Unique, this usage can be Borrowed or Shared (prefered). Can be called + multiple times for multiple barriers (for different branches). *) + val add_barrier : t -> Uniqueness.r -> unit val meet : t -> t -> t @@ -155,12 +155,9 @@ end = struct | [] -> assert false | (_, occ, access) :: _ -> occ, access - let set_barrier t uniq = + let add_barrier t uniq = List.iter - (fun (barrier, _, _) -> - match !barrier with - | None -> barrier := Some uniq - | Some _ -> assert false) + (fun (barrier, _, _) -> barrier := Uniqueness.meet [!barrier; uniq]) t end @@ -400,7 +397,7 @@ end = struct checking of the whole file, m1 will correctly tells whether it needs to be Unique, and by extension whether m0 can be Shared. *) let uniq = Maybe_unique.uniqueness l1 in - Maybe_shared.set_barrier l0 uniq; + Maybe_shared.add_barrier l0 uniq; m1 | Shared _, Borrowed _ -> m0 | Maybe_unique l, Borrowed occ -> @@ -811,7 +808,7 @@ end = struct (* Currently we just generate a dummy unique_barrier ref that won't be consumed. The distinction between implicit and explicit borrowing is still needed because they are handled differently in closures *) - let barrier = ref None in + let barrier = ref (Uniqueness.max |> Uniqueness.disallow_left) in mark (Maybe_shared (Maybe_shared.singleton barrier occ access)) (memory_address paths) From 26a018f33265152ab655c881328acb9d933b8084 Mon Sep 17 00:00:00 2001 From: Richard Eisenberg Date: Mon, 16 Sep 2024 15:59:28 -0400 Subject: [PATCH 45/76] Remove an unnecessary expansion (#3041) --- ocaml/typing/ctype.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/ocaml/typing/ctype.ml b/ocaml/typing/ctype.ml index 1616003bed1..49bbe0a24f1 100644 --- a/ocaml/typing/ctype.ml +++ b/ocaml/typing/ctype.ml @@ -2387,8 +2387,7 @@ let type_jkind_purely env ty = type_jkind env ty let estimate_type_jkind env ty = - estimate_type_jkind env ~expand_components:(fun x -> x) - (get_unboxed_type_approximation env ty) + estimate_type_jkind env ~expand_components:(fun x -> x) ty let type_sort ~why env ty = let jkind, sort = Jkind.of_new_sort_var ~why in From a6eefb188891164263b717e679401d7216fb9153 Mon Sep 17 00:00:00 2001 From: Zesen Qian Date: Tue, 17 Sep 2024 13:55:08 +0100 Subject: [PATCH 46/76] mode crossing in inclusion check (#3043) --- .../testsuite/tests/typing-modes/crossing.ml | 89 +++++++++++++++++++ .../testsuite/tests/typing-modules/pr7726.ml | 1 - ocaml/typing/ctype.ml | 75 ++++++++++------ 3 files changed, 137 insertions(+), 28 deletions(-) create mode 100644 ocaml/testsuite/tests/typing-modes/crossing.ml diff --git a/ocaml/testsuite/tests/typing-modes/crossing.ml b/ocaml/testsuite/tests/typing-modes/crossing.ml new file mode 100644 index 00000000000..81b43e62a5e --- /dev/null +++ b/ocaml/testsuite/tests/typing-modes/crossing.ml @@ -0,0 +1,89 @@ +(* TEST + expect; +*) + +(* mode crossing during inclusion check is according to the written type, not +the inferred type. *) + +(* In this example, the inferred type does not allow mode crossing, but the +written type does. *) +module M : sig + val f : int @ nonportable -> int @ portable +end = struct + let f (x @ portable) = (x : _ @@ nonportable) +end +[%%expect{| +module M : sig val f : int -> int @ portable end +|}] + +(* In this example, the inferred type allows crossing to portable, but the +written type does not. *) +module M : sig + val f : unit -> [`A | `B of 'a -> 'a] @ portable +end = struct + let f () = (`A : _ @@ nonportable) +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f () = (`A : _ @@ nonportable) +5 | end +Error: Signature mismatch: + Modules do not match: + sig val f : unit -> [> `A ] end + is not included in + sig val f : unit -> [ `A | `B of 'a -> 'a ] @ portable end + Values do not match: + val f : unit -> [> `A ] + is not included in + val f : unit -> [ `A | `B of 'a -> 'a ] @ portable + The type unit -> [ `A | `B of 'a -> 'a ] + is not compatible with the type + unit -> [ `A | `B of 'a -> 'a ] @ portable +|}] + +(* In this example, the inferred type does not allow crossing portability, but +the written type does. *) +module M : sig + val f : [`A] @ nonportable -> unit +end = struct + let f (x : [< `A | `B of string -> string] @@ portable) = + match x with + | `A -> () + | `B f -> () +end +[%%expect{| +module M : sig val f : [ `A ] -> unit end +|}] + +module M : sig + val f : unit -> int +end = struct + let f () = exclave_ 42 +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f () = exclave_ 42 +5 | end +Error: Signature mismatch: + Modules do not match: + sig val f : unit -> local_ int end + is not included in + sig val f : unit -> int end + Values do not match: + val f : unit -> local_ int + is not included in + val f : unit -> int + The type unit -> local_ int is not compatible with the type + unit -> int +|}] + +module M : sig + val f : local_ int -> int +end = struct + let f (_ @ global) = 42 +end +[%%expect{| +module M : sig val f : local_ int -> int end +|}] diff --git a/ocaml/testsuite/tests/typing-modules/pr7726.ml b/ocaml/testsuite/tests/typing-modules/pr7726.ml index 6ea1b7f5ea3..63ede925105 100644 --- a/ocaml/testsuite/tests/typing-modules/pr7726.ml +++ b/ocaml/testsuite/tests/typing-modules/pr7726.ml @@ -123,7 +123,6 @@ M.f 5;; [%%expect{| module Foo : functor (F : T -> T) -> sig val f : Fix(F).Fixed.t -> Fix(F).Fixed.t end -module M : sig val f : Fix(Id).Fixed.t -> Fix(Id).Fixed.t end Line 1: Error: In the signature of Fix(Id): The definition of Fixed.t contains a cycle: diff --git a/ocaml/typing/ctype.ml b/ocaml/typing/ctype.ml index 49bbe0a24f1..54c951b831c 100644 --- a/ocaml/typing/ctype.ml +++ b/ocaml/typing/ctype.ml @@ -4723,12 +4723,49 @@ let relevant_pairs pairs v = | Contravariant -> pairs.contravariant_pairs | Bivariant -> pairs.bivariant_pairs -let moregen_alloc_mode v a1 a2 = +(* CR layouts v2.8: merge with Typecore.mode_cross_left when [Value] and [Alloc] + get unified *) +let mode_cross_left env ty mode = + (* CR layouts v2.8: The old check didn't check for principality, and so this + one doesn't either. I think it should. But actually test results are bad + when checking for principality. Really, I'm surprised that the types here + aren't principal. In any case, leaving the check out now; will return and + figure this out later. *) + let jkind = type_jkind_purely env ty in + let upper_bounds = Jkind.get_modal_upper_bounds jkind in + Alloc.meet_const upper_bounds mode + +(* CR layouts v2.8: merge with Typecore.expect_mode_cross when [Value] and + [Alloc] get unified *) +let mode_cross_right env ty mode = + (* CR layouts v2.8: This should probably check for principality. See similar + comment in [mode_cross_left]. *) + let jkind = type_jkind_purely env ty in + let upper_bounds = Jkind.get_modal_upper_bounds jkind in + Alloc.imply upper_bounds mode + +let submode_with_cross env ~is_ret ty l r = + let r' = mode_cross_right env ty r in + let r' = + if is_ret then + (* the locality axis of the return mode cannot cross modes, because a + local-returning function might allocate in the caller's region, and + this info must be preserved. *) + Alloc.meet [r'; Alloc.max_with (Comonadic Areality) (Alloc.proj (Comonadic Areality) r)] + else + r' + in + Alloc.submode l r' + +let moregen_alloc_mode env ~is_ret ty v a1 a2 = match match v with - | Invariant -> Result.map_error ignore (Alloc.equate a1 a2) - | Covariant -> Result.map_error ignore (Alloc.submode a1 a2) - | Contravariant -> Result.map_error ignore (Alloc.submode a2 a1) + | Invariant -> + Result.bind (submode_with_cross env ~is_ret ty a1 a2) + (fun _ -> submode_with_cross env ~is_ret ty a2 a1) + |> Result.map_error ignore + | Covariant -> Result.map_error ignore (submode_with_cross env ~is_ret ty a1 a2) + | Contravariant -> Result.map_error ignore (submode_with_cross env ~is_ret ty a2 a1) | Bivariant -> Ok () with | Ok () -> () @@ -4776,8 +4813,13 @@ let rec moregen inst_nongen variance type_pairs env t1 t2 = || !Clflags.classic && equivalent_with_nolabels l1 l2) -> moregen inst_nongen (neg_variance variance) type_pairs env t1 t2; moregen inst_nongen variance type_pairs env u1 u2; - moregen_alloc_mode (neg_variance variance) a1 a2; - moregen_alloc_mode variance r1 r2 + (* [t2] and [u2] is the user-written interface, which we deem as + more "principal" and used for mode crossing. See + [typing-modes/crossing.ml]. *) + (* CR zqian: should use the meet of [t1] and [t2] for mode + crossing. Similar for [u1] and [u2]. *) + moregen_alloc_mode env t2 ~is_ret:false (neg_variance variance) a1 a2; + moregen_alloc_mode env u2 ~is_ret:true variance r1 r2 | (Ttuple labeled_tl1, Ttuple labeled_tl2) -> moregen_labeled_list inst_nongen variance type_pairs env labeled_tl1 labeled_tl2 @@ -5748,27 +5790,6 @@ let build_submode posi m = if posi then build_submode_pos (Alloc.allow_left m) else build_submode_neg (Alloc.allow_right m) -(* CR layouts v2.8: merge with Typecore.mode_cross_left when [Value] and - [Alloc] get unified *) -let mode_cross_left env ty mode = - (* CR layouts v2.8: The old check didn't check for principality, and so - this one doesn't either. I think it should. But actually test results - are bad when checking for principality. Really, I'm surprised that - the types here aren't principal. In any case, leaving the check out - now; will return and figure this out later. *) - let jkind = type_jkind_purely env ty in - let upper_bounds = Jkind.get_modal_upper_bounds jkind in - Alloc.meet_const upper_bounds mode - -(* CR layouts v2.8: merge with Typecore.expect_mode_cross when [Value] - and [Alloc] get unified *) -let mode_cross_right env ty mode = - (* CR layouts v2.8: This should probably check for principality. See - similar comment in [mode_cross_left]. *) - let jkind = type_jkind_purely env ty in - let upper_bounds = Jkind.get_modal_upper_bounds jkind in - Alloc.imply upper_bounds mode - let rec build_subtype env (visited : transient_expr list) (loops : (int * type_expr) list) posi level t = match get_desc t with From ea387c22c51bbe32de5c3c992fde88600a071a18 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 17 Sep 2024 14:00:05 +0100 Subject: [PATCH 47/76] %identity-related changes (#3044) --- ocaml/runtime/misc.c | 10 ++++++++-- ocaml/runtime4/misc.c | 10 ++++++++-- ocaml/stdlib/obj.ml | 4 ++-- ocaml/stdlib/obj.mli | 4 ++-- ocaml/testsuite/tests/lib-obj/with_tag.ml | 16 ++++++++++++++++ 5 files changed, 36 insertions(+), 8 deletions(-) diff --git a/ocaml/runtime/misc.c b/ocaml/runtime/misc.c index 865806d5b56..fa101cace46 100644 --- a/ocaml/runtime/misc.c +++ b/ocaml/runtime/misc.c @@ -280,7 +280,13 @@ void caml_flambda2_invalid (value message) { fprintf (stderr, "[ocaml] [flambda2] Invalid code:\n%s\n\n", String_val(message)); - fprintf (stderr, "This might have arisen from a wrong use of [Obj.magic].\n"); - fprintf (stderr, "Consider using [Sys.opaque_identity].\n"); + fprintf (stderr, + "This might have arisen from a wrong use of [%%identity],\n"); + fprintf (stderr, + "for example confusing arrays and records, or non-mixed and\n"); + fprintf (stderr, + "mixed blocks.\n"); + fprintf (stderr, + "Consider using [Obj.magic], [Obj.repr] and/or [Obj.obj].\n"); abort (); } diff --git a/ocaml/runtime4/misc.c b/ocaml/runtime4/misc.c index 5208ebb38cd..7d41f11b400 100644 --- a/ocaml/runtime4/misc.c +++ b/ocaml/runtime4/misc.c @@ -225,8 +225,14 @@ void caml_flambda2_invalid (value message) { fprintf (stderr, "[ocaml] [flambda2] Invalid code:\n%s\n\n", String_val(message)); - fprintf (stderr, "This might have arisen from a wrong use of [Obj.magic].\n"); - fprintf (stderr, "Consider using [Sys.opaque_identity].\n"); + fprintf (stderr, + "This might have arisen from a wrong use of [%%identity],\n"); + fprintf (stderr, + "for example confusing arrays and records, or non-mixed and\n"); + fprintf (stderr, + "mixed blocks.\n"); + fprintf (stderr, + "Consider using [Obj.magic], [Obj.repr] and/or [Obj.obj].\n"); abort (); } diff --git a/ocaml/stdlib/obj.ml b/ocaml/stdlib/obj.ml index 1530132fc3e..51427ec9cb6 100644 --- a/ocaml/stdlib/obj.ml +++ b/ocaml/stdlib/obj.ml @@ -24,8 +24,8 @@ type t type raw_data = nativeint -external repr : 'a -> t = "%identity" -external obj : t -> 'a = "%identity" +external repr : 'a -> t = "%obj_magic" +external obj : t -> 'a = "%obj_magic" external magic : 'a -> 'b = "%obj_magic" external is_int : t -> bool = "%obj_is_int" let [@inline always] is_block a = not (is_int a) diff --git a/ocaml/stdlib/obj.mli b/ocaml/stdlib/obj.mli index 8deec52e2be..ca007bab346 100644 --- a/ocaml/stdlib/obj.mli +++ b/ocaml/stdlib/obj.mli @@ -25,8 +25,8 @@ type t type raw_data = nativeint (* @since 4.12 *) -external repr : 'a -> t = "%identity" -external obj : t -> 'a = "%identity" +external repr : 'a -> t = "%obj_magic" +external obj : t -> 'a = "%obj_magic" external magic : 'a -> 'b = "%obj_magic" val is_block : t -> bool external is_int : t -> bool = "%obj_is_int" diff --git a/ocaml/testsuite/tests/lib-obj/with_tag.ml b/ocaml/testsuite/tests/lib-obj/with_tag.ml index bf13cb83e28..d12faf73109 100644 --- a/ocaml/testsuite/tests/lib-obj/with_tag.ml +++ b/ocaml/testsuite/tests/lib-obj/with_tag.ml @@ -11,6 +11,19 @@ let () = let () = assert (Obj.tag (Obj.with_tag 42 (Obj.repr [| |])) = 42) +(* CR mshinwell/vlaviron: Disabling these for now. Suggestions from Vincent: + + A proper solution could be to have a proper %with_tag primitive, with type + int -> 'a -> 'a, that doesn't require going through Obj.t. + + As a bonus, that would allow things like LexiFi's Obj.with_tag Obj.object_tag + foo, which currently doesn't work because Obj.object_tag isn't a Lambda + constant. +*) + +(* + + (* check optimisations *) let raw_allocs f = let before = Gc.minor_words () in @@ -26,5 +39,8 @@ let () = assert (allocs (fun () -> Obj.with_tag 1 (Obj.repr (A ("hello", 10.)))) = 0); assert (allocs (fun [@inline never] () -> Obj.with_tag 1 (Obj.repr (ref 10))) = 2) +*) + let () = print_endline "ok" + From 4f38ab9eb754bbc48c87c49b4ea05692f8110f1e Mon Sep 17 00:00:00 2001 From: Vincent Laviron Date: Tue, 17 Sep 2024 15:42:16 +0200 Subject: [PATCH 48/76] Add summary comments on recursive value compilation (#3045) --- ocaml/lambda/value_rec_compiler.mli | 23 +++++++++++++++++++++++ ocaml/typing/value_rec_types.mli | 3 ++- 2 files changed, 25 insertions(+), 1 deletion(-) diff --git a/ocaml/lambda/value_rec_compiler.mli b/ocaml/lambda/value_rec_compiler.mli index fd4d1c338fb..6ddd0eef68f 100644 --- a/ocaml/lambda/value_rec_compiler.mli +++ b/ocaml/lambda/value_rec_compiler.mli @@ -12,6 +12,29 @@ (* *) (**************************************************************************) +(** Overview of the compilation scheme + + Given a set of recursive definitions, we sort them into four categories: + + - Non-recursive definitions (more precisely, definitions classified as + [Dynamic] by [Value_rec_check]). These are compiled as regular + let-bindings, inserted before the rest. + - Constant definitions. These are definitions that have been classified + as [Static], but cannot be pre-allocated and cannot end up actually using + recursive values (i.e. let rec x = let _ = x in 0). These are compiled to + regular bindings too, modulo some renaming to remove references to + recursive variables. + - Blocks of static size. These are pre-allocated, new values are computed + from the definitions, and the contents of the new values is copied back + to the original allocation. + - Functional values. These are defined together in a single recursive block + full of functions. The definition occurs after the pre-allocation + (so the functions can refer to the recursive blocks) but before the + back-patching (so the block definitions can refer to the functions). + + More detailed comments are available in the implementation. +*) + val compile_letrec : (Ident.t * Value_rec_types.recursive_binding_kind * Lambda.lambda) list -> Lambda.lambda -> diff --git a/ocaml/typing/value_rec_types.mli b/ocaml/typing/value_rec_types.mli index a907935cc9f..471216c8122 100644 --- a/ocaml/typing/value_rec_types.mli +++ b/ocaml/typing/value_rec_types.mli @@ -21,7 +21,8 @@ type recursive_binding_kind = | Static (** Bindings for which some kind of pre-allocation scheme is possible. The expression is allowed to be recursive, as long as its definition does - not inspect recursively defined values. *) + not inspect recursively defined values. + See [Value_rec_compiler] for more details on the compilation scheme. *) | Dynamic (** Bindings for which pre-allocation is not possible. The expression is not allowed to refer to any recursive variable. *) From 070e7253476d6ac108f5af642a66eea19a855edf Mon Sep 17 00:00:00 2001 From: Aina Linn Georges Date: Tue, 17 Sep 2024 16:30:11 +0100 Subject: [PATCH 49/76] Renamed shared to aliased (#3047) --- chamelon/compat.jst.ml | 2 +- ...test_locations.dlocations.ocamlc.reference | 6 +- ...t_locations.dno-locations.ocamlc.reference | 6 +- .../testsuite/tests/typing-layouts/annots.ml | 96 +++--- .../testsuite/tests/typing-layouts/jkinds.ml | 44 +-- .../tests/typing-modal-kinds/basics.ml | 6 +- .../tests/typing-modal-kinds/expected_mode.ml | 18 +- ocaml/testsuite/tests/typing-modes/class.ml | 4 +- ocaml/testsuite/tests/typing-modes/modes.ml | 28 +- ocaml/testsuite/tests/typing-modes/mutable.ml | 8 +- .../tests/typing-modes/val_modalities.ml | 4 +- ocaml/testsuite/tests/typing-unique/unique.ml | 64 ++-- .../tests/typing-unique/unique_analysis.ml | 80 ++--- .../tests/typing-unique/unique_mod_class.ml | 16 +- .../tests/typing-unique/unique_typedecl.ml | 4 +- ocaml/typing/ctype.ml | 10 +- ocaml/typing/env.ml | 4 +- ocaml/typing/mode.ml | 22 +- ocaml/typing/mode_intf.mli | 4 +- ocaml/typing/typeclass.ml | 4 +- ocaml/typing/typecore.ml | 8 +- ocaml/typing/typedtree.ml | 4 +- ocaml/typing/typedtree.mli | 4 +- ocaml/typing/typemode.ml | 4 +- ocaml/typing/uniqueness_analysis.ml | 294 +++++++++--------- 25 files changed, 374 insertions(+), 370 deletions(-) diff --git a/chamelon/compat.jst.ml b/chamelon/compat.jst.ml index 1fb18096196..f188e227993 100644 --- a/chamelon/compat.jst.ml +++ b/chamelon/compat.jst.ml @@ -16,7 +16,7 @@ let mkTarrow (label, t1, t2, comm) = type texp_ident_identifier = ident_kind * unique_use -let mkTexp_ident ?id:(ident_kind, uu = (Id_value, shared_many_use)) +let mkTexp_ident ?id:(ident_kind, uu = (Id_value, aliased_many_use)) (path, longident, vd) = Texp_ident (path, longident, vd, ident_kind, uu) diff --git a/ocaml/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference b/ocaml/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference index 4c5dd0cd3ab..7a75bc5e8d3 100644 --- a/ocaml/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference +++ b/ocaml/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference @@ -89,13 +89,13 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2)) pattern (test_locations.ml[17,534+8]..test_locations.ml[17,534+11]) Tpat_var "fib" - value_mode global,many,nonportable;join(shared,contended)(modevar#1[shared,uncontended .. unique,uncontended]) + value_mode global,many,nonportable;join(aliased,contended)(modevar#1[aliased,uncontended .. unique,uncontended]) expression (test_locations.ml[17,534+14]..test_locations.ml[19,572+34]) Texp_function - alloc_mode global,many,nonportable;id(modevar#7[shared,contended .. unique,uncontended]) + alloc_mode global,many,nonportable;id(modevar#7[aliased,contended .. unique,uncontended]) [] Tfunction_cases (test_locations.ml[17,534+14]..test_locations.ml[19,572+34]) - alloc_mode global,many,nonportable;shared,uncontended + alloc_mode global,many,nonportable;aliased,uncontended value [ diff --git a/ocaml/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference b/ocaml/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference index 2e587536b8e..93910acca50 100644 --- a/ocaml/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference +++ b/ocaml/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference @@ -89,13 +89,13 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2)) pattern Tpat_var "fib" - value_mode global,many,nonportable;join(shared,contended)(modevar#1[shared,uncontended .. unique,uncontended]) + value_mode global,many,nonportable;join(aliased,contended)(modevar#1[aliased,uncontended .. unique,uncontended]) expression Texp_function - alloc_mode global,many,nonportable;id(modevar#7[shared,contended .. unique,uncontended]) + alloc_mode global,many,nonportable;id(modevar#7[aliased,contended .. unique,uncontended]) [] Tfunction_cases - alloc_mode global,many,nonportable;shared,uncontended + alloc_mode global,many,nonportable;aliased,uncontended value [ diff --git a/ocaml/testsuite/tests/typing-layouts/annots.ml b/ocaml/testsuite/tests/typing-layouts/annots.ml index 6ebb79a4c31..6574e57ba55 100644 --- a/ocaml/testsuite/tests/typing-layouts/annots.ml +++ b/ocaml/testsuite/tests/typing-layouts/annots.ml @@ -53,7 +53,7 @@ type t_value_mod_local : value mod local type t_value_mod_many : value mod many type t_value_mod_once : value mod once type t_value_mod_unique : value mod unique -type t_value_mod_shared : value mod shared +type t_value_mod_aliased : value mod aliased type t_value_mod_internal : value mod internal type t_value_mod_contended : value mod contended type t_value_mod_uncontended : value mod uncontended @@ -68,7 +68,7 @@ type t_value_mod_local type t_value_mod_many : value mod many type t_value_mod_once type t_value_mod_unique : value mod unique -type t_value_mod_shared +type t_value_mod_aliased type t_value_mod_internal type t_value_mod_contended type t_value_mod_uncontended : value mod uncontended @@ -78,12 +78,12 @@ type t_value_mod_external : value mod external_ type t_value_mod_external64 : value mod external64 |}] -type t1 : float32 mod internal shared many local +type t1 : float32 mod internal aliased many local type t2 : bits64 mod once external64 unique type t3 : immediate mod local unique [%%expect {| -type t1 : float32 mod internal shared many local +type t1 : float32 mod internal aliased many local type t2 : bits64 mod once external64 unique type t3 : immediate mod local unique |}] @@ -168,11 +168,11 @@ Line 1, characters 32-40: Error: The nullability axis has already been specified. |}] -type t14 : value mod unique shared +type t14 : value mod unique aliased [%%expect {| -Line 1, characters 28-34: -1 | type t14 : value mod unique shared - ^^^^^^ +Line 1, characters 28-35: +1 | type t14 : value mod unique aliased + ^^^^^^^ Error: The uniqueness axis has already been specified. |}] @@ -184,11 +184,11 @@ Line 1, characters 19-22: Error: Unrecognized modifier foo. |}] -type t : value mod global shared bar +type t : value mod global aliased bar [%%expect {| -Line 1, characters 33-36: -1 | type t : value mod global shared bar - ^^^ +Line 1, characters 34-37: +1 | type t : value mod global aliased bar + ^^^ Error: Unrecognized modifier bar. |}] @@ -214,7 +214,7 @@ Error: Unrecognized modifier fizzbuzz. let x : int as ('a: value) = 5 let x : int as ('a : immediate) = 5 let x : int as ('a : any) = 5;; -let x : int as ('a: value mod global shared many uncontended portable external_) = 5 +let x : int as ('a: value mod global aliased many uncontended portable external_) = 5 [%%expect{| val x : int = 5 @@ -300,8 +300,8 @@ type (_ : float64) t2_float64' type t3 = float# t2_float64 type ('a : value mod global) t2_global type (_ : value mod global) t2_global' -type ('a : word mod external_ many shared) t2_complex -type (_ : word mod external_ many shared) t2_complex' +type ('a : word mod external_ many aliased) t2_complex +type (_ : word mod external_ many aliased) t2_complex' [%%expect {| @@ -370,15 +370,15 @@ module M2 : sig type (_ : value mod global) t end |}] module M1 : sig - type ('a : word mod external_ many shared) t + type ('a : word mod external_ many aliased) t end = struct - type (_ : word mod external_ many shared) t + type (_ : word mod external_ many aliased) t end module M2 : sig - type (_ : word mod external_ many shared) t + type (_ : word mod external_ many aliased) t end = struct - type ('a : word mod external_ many shared) t + type ('a : word mod external_ many aliased) t end [%%expect {| @@ -425,7 +425,7 @@ Error: This type u should be an instance of type The kind of u is word because of the definition of u at line 1, characters 0-13. But the kind of u must be a subkind of word mod many external_ - because of the definition of t2_complex at line 10, characters 0-53. + because of the definition of t2_complex at line 10, characters 0-54. |}] let f : 'a t2_imm -> 'a t2_imm = fun x -> x @@ -440,7 +440,7 @@ val f : ('a : word mod many external_). 'a t2_complex -> 'a t2_complex = let f : ('a : immediate) t2_imm -> ('a : value) t2_imm = fun x -> x let f : ('a : value mod global) t2_global -> ('a : value) t2_global = fun x -> x -let f : ('a : word mod external_ many shared) t2_complex -> ('a : word) t2_complex = fun x -> x +let f : ('a : word mod external_ many aliased) t2_complex -> ('a : word) t2_complex = fun x -> x [%%expect {| val f : ('a : immediate). 'a t2_imm -> 'a t2_imm = val f : ('a : value mod global). 'a t2_global -> 'a t2_global = @@ -460,7 +460,7 @@ val f : ('a : word mod many external_). 'a t2_complex -> 'a t2_complex = let f : ('a : immediate). 'a t2_imm -> 'a t2_imm = fun x -> x let f : ('a : value mod global). 'a t2_global -> 'a t2_global = fun x -> x -let f : ('a : word mod external_ many shared). 'a t2_complex -> 'a t2_complex = fun x -> x +let f : ('a : word mod external_ many aliased). 'a t2_complex -> 'a t2_complex = fun x -> x [%%expect {| val f : ('a : immediate). 'a t2_imm -> 'a t2_imm = val f : ('a : value mod global). 'a t2_global -> 'a t2_global = @@ -498,7 +498,7 @@ Line 1, characters 8-51: ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The universal type variable 'a was declared to have kind word. But it was inferred to have kind word mod many external_ - because of the definition of t2_complex at line 10, characters 0-53. + because of the definition of t2_complex at line 10, characters 0-54. |}] type 'a t = 'a t2_imm @@ -521,7 +521,7 @@ type ('a : word mod many external_) t = 'a t2_complex type ('a : immediate) t = 'a t2_imm type ('a : value mod global) t = 'a t2_global -type ('a : word mod external_ many shared) t = 'a t2_complex +type ('a : word mod external_ many aliased) t = 'a t2_complex [%%expect {| type ('a : immediate) t = 'a t2_imm type ('a : value mod global) t = 'a t2_global @@ -535,7 +535,7 @@ let f : (_ : value) t2_global -> unit = fun _ -> () let g : (_ : value mod global) t2_global -> unit = fun _ -> () let f : (_ : word) t2_complex -> unit = fun _ -> () -let g : (_ : word mod external_ many shared) t2_complex -> unit = fun _ -> () +let g : (_ : word mod external_ many aliased) t2_complex -> unit = fun _ -> () [%%expect {| val f : ('a : immediate). 'a t2_imm -> unit = @@ -548,7 +548,7 @@ val g : ('a : word mod many external_). 'a t2_complex -> unit = let f : (_ : immediate) -> unit = fun _ -> () let f : (_ : value mod global) -> unit = fun _ -> () -let f : (_ : word mod external_ many shared) -> unit = fun _ -> () +let f : (_ : word mod external_ many aliased) -> unit = fun _ -> () let g : (_ : value) -> unit = fun _ -> () [%%expect {| @@ -564,8 +564,8 @@ let g : (_ : value) -> (_ : immediate) = fun _ -> assert false let f : (_ : value mod global) -> (_ : value) = fun _ -> assert false let g : (_ : value) -> (_ : value mod global) = fun _ -> assert false -let f : (_ : word mod external_ many shared) -> (_ : value) = fun _ -> assert false -let g : (_ : value) -> (_ : word mod external_ many shared) = fun _ -> assert false +let f : (_ : word mod external_ many aliased) -> (_ : value) = fun _ -> assert false +let g : (_ : value) -> (_ : word mod external_ many aliased) = fun _ -> assert false [%%expect {| val f : ('a : immediate) 'b. 'a -> 'b = @@ -632,9 +632,9 @@ type rg = { fieldg : ('a : value mod global). 'a -> 'a; } val f : rg -> int = |}] -type rc = { fieldc : ('a : word mod external_ many shared). 'a -> 'a } +type rc = { fieldc : ('a : word mod external_ many aliased). 'a -> 'a } let f { fieldc } = - let x : _ as (_ : word mod external_ many shared) = assert false in + let x : _ as (_ : word mod external_ many aliased) = assert false in fieldc x;; [%%expect {| type rc = { fieldc : ('a : word mod many external_). 'a -> 'a; } @@ -680,7 +680,7 @@ Error: This expression has type string but an expression was expected of type The layout of string is value because it is the primitive type string. But the layout of string must be a sublayout of word - because of the definition of rc at line 1, characters 0-70. + because of the definition of rc at line 1, characters 0-71. |}] let r = { field = fun x -> x } @@ -785,7 +785,7 @@ Error: Layout mismatch in final type declaration consistency check. the declaration where this error is reported. |}] -type ('a : word mod external_ many shared) t_complex +type ('a : word mod external_ many aliased) t_complex type s = { f : ('a : word). 'a -> 'a u } and 'a u = 'a t_complex @@ -802,7 +802,7 @@ Error: Layout mismatch in final type declaration consistency check. The kind of 'a is word because of the annotation on the universal variable 'a. But the kind of 'a must be a subkind of word mod many external_ - because of the definition of t_complex at line 1, characters 0-52. + because of the definition of t_complex at line 1, characters 0-53. A good next step is to add a layout annotation on a parameter to the declaration where this error is reported. |}] @@ -834,7 +834,7 @@ let f = fun (type (a : value mod global)) (x : a) -> x val f : ('a : value mod global). 'a -> 'a = |}] -let f = fun (type (a : word mod external_ many shared)) (x : a) -> x +let f = fun (type (a : word mod external_ many aliased)) (x : a) -> x ;; [%%expect {| val f : ('a : word mod many external_). 'a -> 'a = @@ -882,7 +882,7 @@ let f : type (a : value mod global). a -> a = fun x -> x val f : ('a : value mod global). 'a -> 'a = |}] -let f : type (a : word mod external_ many shared). a -> a = fun x -> x +let f : type (a : word mod external_ many aliased). a -> a = fun x -> x ;; [%%expect {| val f : ('a : word mod many external_). 'a -> 'a = @@ -978,7 +978,7 @@ Error: This type ('a : value) should be an instance of type The layout of 'a is value because of the annotation on the universal variable 'a. But the layout of 'a must overlap with word - because of the definition of t2_complex at line 10, characters 0-53. + because of the definition of t2_complex at line 10, characters 0-54. |}] module type S = sig @@ -991,7 +991,7 @@ Line 2, characters 10-53: ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The universal type variable 'a was declared to have kind word. But it was inferred to have kind word mod many external_ - because of the definition of t2_complex at line 10, characters 0-53. + because of the definition of t2_complex at line 10, characters 0-54. |}] module type S = sig @@ -1035,7 +1035,7 @@ module type S = module type S = sig val f : 'a t2_complex -> 'a t2_complex - val g : ('a : word mod external_ many shared). 'a t2_complex -> 'a t2_complex + val g : ('a : word mod external_ many aliased). 'a t2_complex -> 'a t2_complex val h : ('a : word mod external_ many). 'a t2_complex -> 'a t2_complex end ;; @@ -1057,7 +1057,7 @@ let f (x : ('a : value). 'a -> 'a) = x "string", x 5 val f : ('a. 'a -> 'a) -> string * int = |}] -let f (x : ('a : word mod external_ many shared). 'a -> 'a) = +let f (x : ('a : word mod external_ many aliased). 'a -> 'a) = let native_int : nativeint# = assert false in x native_int @@ -1537,7 +1537,7 @@ let f (type a : value) (x : a) = x let f (type a : immediate) (x : a) = x let f (type a : value mod global) (x : a) = x let f (type a : immediate mod global) (x : a) = x -let f (type a : word mod external_ many shared) (x : a) = x +let f (type a : word mod external_ many aliased) (x : a) = x [%%expect{| val f : 'a -> 'a = @@ -1551,7 +1551,7 @@ let f = fun (type a : value) (x : a) -> x let f = fun (type a : immediate) (x : a) -> x let f = fun (type a : value mod global) (x : a) -> x let f = fun (type a : immediate mod global) (x : a) -> x -let f = fun (type a : word mod external_ many shared) (x : a) -> x +let f = fun (type a : word mod external_ many aliased) (x : a) -> x [%%expect{| val f : 'a -> 'a = @@ -1574,7 +1574,7 @@ let o = object method m : type (a : immediate mod global). a -> a = fun x -> x end let o = object - method m : type (a : word mod external_ many shared). a -> a = fun x -> x + method m : type (a : word mod external_ many aliased). a -> a = fun x -> x end [%%expect{| @@ -1589,7 +1589,7 @@ let f : type (a : value). a -> a = fun x -> x let f : type (a : immediate). a -> a = fun x -> x let f : type (a : value mod global). a -> a = fun x -> x let f : type (a : immediate mod global). a -> a = fun x -> x -let f : type (a : word mod external_ many shared). a -> a = fun x -> x +let f : type (a : word mod external_ many aliased). a -> a = fun x -> x [%%expect{| val f : 'a -> 'a = @@ -1616,7 +1616,7 @@ let f x = g x [@nontail] let f x = - let local_ g (type a : word mod external_ many shared) (x : a) = x in + let local_ g (type a : word mod external_ many aliased) (x : a) = x in g x [@nontail] [%%expect{| @@ -1631,7 +1631,7 @@ let f = fun x y (type (a : value)) (z : a) -> z let f = fun x y (type (a : immediate)) (z : a) -> z let f = fun x y (type (a : value mod global)) (z : a) -> z let f = fun x y (type (a : immediate mod global)) (z : a) -> z -let f = fun x y (type (a : word mod external_ many shared)) (z : a) -> z +let f = fun x y (type (a : word mod external_ many aliased)) (z : a) -> z [%%expect{| val f : 'b -> 'c -> 'a -> 'a = @@ -1645,7 +1645,7 @@ let f = fun x y (type a : value) (z : a) -> z let f = fun x y (type a : immediate) (z : a) -> z let f = fun x y (type a : value mod global) (z : a) -> z let f = fun x y (type a : immediate mod global) (z : a) -> z -let f = fun x y (type a : word mod external_ many shared) (z : a) -> z +let f = fun x y (type a : word mod external_ many aliased) (z : a) -> z [%%expect{| val f : 'b -> 'c -> 'a -> 'a = @@ -1661,7 +1661,7 @@ external f : ('a : value). 'a -> 'a = "%identity" external f : ('a : immediate). 'a -> 'a = "%identity" external f : ('a : value mod global). 'a -> 'a = "%identity" external f : ('a : immediate mod global). 'a -> 'a = "%identity" -external f : ('a : word mod external_ many shared). 'a -> 'a = "%identity" +external f : ('a : word mod external_ many aliased). 'a -> 'a = "%identity" [%%expect{| external f : 'a -> 'a = "%identity" @@ -1748,7 +1748,7 @@ type t = int as (_ : value) type t = int as (_ : immediate) type t = int as (_ : value mod global) type t = int as (_ : immediate mod global) -type t = nativeint# as (_ : word mod external_ many shared) +type t = nativeint# as (_ : word mod external_ many aliased) [%%expect {| type t = int diff --git a/ocaml/testsuite/tests/typing-layouts/jkinds.ml b/ocaml/testsuite/tests/typing-layouts/jkinds.ml index 8f0e2c10b49..205ae934968 100644 --- a/ocaml/testsuite/tests/typing-layouts/jkinds.ml +++ b/ocaml/testsuite/tests/typing-layouts/jkinds.ml @@ -215,24 +215,24 @@ Error: The layout of type a is value |}] type a : value mod global unique many uncontended portable external_ -type b : value mod local shared once contended nonportable internal = a +type b : value mod local aliased once contended nonportable internal = a [%%expect{| type a : value mod global unique many uncontended portable external_ type b = a |}] type a : value mod global unique once uncontended portable external_ -type b : value mod local shared many uncontended nonportable internal = a +type b : value mod local aliased many uncontended nonportable internal = a [%%expect{| type a : value mod global unique once uncontended portable external_ -Line 2, characters 0-73: -2 | type b : value mod local shared many uncontended nonportable internal = a - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Line 2, characters 0-74: +2 | type b : value mod local aliased many uncontended nonportable internal = a + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The kind of type a is value mod global unique uncontended portable external_ because of the definition of a at line 1, characters 0-68. But the kind of type a must be a subkind of value mod many uncontended - because of the definition of b at line 2, characters 0-73. + because of the definition of b at line 2, characters 0-74. |}] (********************************************************) @@ -240,19 +240,19 @@ Error: The kind of type a is (* CR layouts: when we have abbreviations, these tests can become less verbose *) type a : any -type b : any mod local shared once contended nonportable internal = a -type c : any mod local shared once contended nonportable internal +type b : any mod local aliased once contended nonportable internal = a +type c : any mod local aliased once contended nonportable internal type d : any = c [%%expect{| type a : any type b = a -type c : any mod local shared once contended nonportable internal +type c : any mod local aliased once contended nonportable internal type d = c |}] type a : value -type b : value mod local shared once contended nonportable internal = a -type c : value mod local shared once contended nonportable internal +type b : value mod local aliased once contended nonportable internal = a +type c : value mod local aliased once contended nonportable internal type d : value = c [%%expect{| type a @@ -262,8 +262,8 @@ type d = c |}] type a : void -type b : void mod local shared once contended nonportable internal = a -type c : void mod local shared once contended nonportable internal +type b : void mod local aliased once contended nonportable internal = a +type c : void mod local aliased once contended nonportable internal type d : void = c [%%expect{| Line 1, characters 9-13: @@ -318,35 +318,35 @@ type d = c |}] type a : word -type b : word mod local shared once contended nonportable internal = a -type c : word mod local shared once contended nonportable internal +type b : word mod local aliased once contended nonportable internal = a +type c : word mod local aliased once contended nonportable internal type d : word = c [%%expect{| type a : word type b = a -type c : word mod local shared once contended nonportable internal +type c : word mod local aliased once contended nonportable internal type d = c |}] type a : bits32 -type b : bits32 mod local shared once contended nonportable internal = a -type c : bits32 mod local shared once contended nonportable internal +type b : bits32 mod local aliased once contended nonportable internal = a +type c : bits32 mod local aliased once contended nonportable internal type d : bits32 = c [%%expect{| type a : bits32 type b = a -type c : bits32 mod local shared once contended nonportable internal +type c : bits32 mod local aliased once contended nonportable internal type d = c |}] type a : bits64 -type b : bits64 mod local shared once contended nonportable internal = a -type c : bits64 mod local shared once contended nonportable internal +type b : bits64 mod local aliased once contended nonportable internal = a +type c : bits64 mod local aliased once contended nonportable internal type d : bits64 = c [%%expect{| type a : bits64 type b = a -type c : bits64 mod local shared once contended nonportable internal +type c : bits64 mod local aliased once contended nonportable internal type d = c |}] diff --git a/ocaml/testsuite/tests/typing-modal-kinds/basics.ml b/ocaml/testsuite/tests/typing-modal-kinds/basics.ml index 82822877fb6..1368916e44f 100644 --- a/ocaml/testsuite/tests/typing-modal-kinds/basics.ml +++ b/ocaml/testsuite/tests/typing-modal-kinds/basics.ml @@ -487,7 +487,7 @@ let hidden_string_unshare = Line 2, characters 75-76: 2 | let x : Hidden_string.t = Hidden_string.hide "hello" in ignore x; unique x ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] let hidden_int_unshare = @@ -514,7 +514,7 @@ let hidden_string_list_unshare = Line 4, characters 22-23: 4 | in ignore x; unique x ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] let hidden_int_list_unshare = @@ -615,7 +615,7 @@ let hidden_int64_u_unshare () = Line 3, characters 35-36: 3 | Int64_u.ignore x; Int64_u.unique x ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] let float_u_record_unshare = diff --git a/ocaml/testsuite/tests/typing-modal-kinds/expected_mode.ml b/ocaml/testsuite/tests/typing-modal-kinds/expected_mode.ml index 164fcf6433b..25e9de03434 100644 --- a/ocaml/testsuite/tests/typing-modal-kinds/expected_mode.ml +++ b/ocaml/testsuite/tests/typing-modal-kinds/expected_mode.ml @@ -310,7 +310,7 @@ let string_unshare : _ -> unique_ string = fun x -> x Line 1, characters 52-53: 1 | let string_unshare : _ -> unique_ string = fun x -> x ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] let int_unshare : _ -> unique_ int = fun x -> x @@ -325,7 +325,7 @@ let string_list_unshare : _ -> unique_ string list = fun x -> x Line 1, characters 62-63: 1 | let string_list_unshare : _ -> unique_ string list = fun x -> x ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] let int_list_unshare : _ -> unique_ int list = fun x -> x @@ -334,7 +334,7 @@ let int_list_unshare : _ -> unique_ int list = fun x -> x Line 1, characters 56-57: 1 | let int_list_unshare : _ -> unique_ int list = fun x -> x ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] let function_unshare : _ -> unique_ (int -> int) = fun x -> x @@ -350,7 +350,7 @@ let hidden_string_unshare : _ -> unique_ Hidden_string.t = Line 2, characters 11-12: 2 | fun x -> x ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] let hidden_int_unshare : _ -> unique_ Hidden_int.t = @@ -366,7 +366,7 @@ let float_unshare : _ -> unique_ float = fun x -> x Line 1, characters 50-51: 1 | let float_unshare : _ -> unique_ float = fun x -> x ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] let float_u_unshare : _ -> unique_ float# = fun x -> x @@ -389,7 +389,7 @@ let float_u_record_unshare : _ -> unique_ float_u_record = Line 2, characters 11-12: 2 | fun x -> x ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] let float_u_record_list_unshare : @@ -400,7 +400,7 @@ let float_u_record_list_unshare : Line 3, characters 11-12: 3 | fun x -> x ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] let hidden_function_unshare : _ -> unique_ (int, int) Hidden_function.t = fun x -> x @@ -409,7 +409,7 @@ let hidden_function_unshare : _ -> unique_ (int, int) Hidden_function.t = fun x Line 1, characters 83-84: 1 | let hidden_function_unshare : _ -> unique_ (int, int) Hidden_function.t = fun x -> x ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] let function_list_unshare : _ -> unique_ (int -> int) list = @@ -419,5 +419,5 @@ let function_list_unshare : _ -> unique_ (int -> int) list = Line 2, characters 11-12: 2 | fun x -> x ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] diff --git a/ocaml/testsuite/tests/typing-modes/class.ml b/ocaml/testsuite/tests/typing-modes/class.ml index 62b6fd21d79..8f45b137ac3 100644 --- a/ocaml/testsuite/tests/typing-modes/class.ml +++ b/ocaml/testsuite/tests/typing-modes/class.ml @@ -31,7 +31,7 @@ Line 5, characters 16-17: Error: The value s is local, so cannot be used inside a class. |}] -(* class can refer to external unique things, but only as shared. *) +(* class can refer to external unique things, but only as aliased. *) let foo () = let unique_ s = "hello" in let module M = struct @@ -43,7 +43,7 @@ let foo () = Line 5, characters 27-28: 5 | val k = unique_use s ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. Hint: This identifier cannot be used uniquely, because it is defined in a class. |}] diff --git a/ocaml/testsuite/tests/typing-modes/modes.ml b/ocaml/testsuite/tests/typing-modes/modes.ml index 05db9274c4e..e3cff0f19f7 100644 --- a/ocaml/testsuite/tests/typing-modes/modes.ml +++ b/ocaml/testsuite/tests/typing-modes/modes.ml @@ -101,7 +101,7 @@ val foo : bar:string -> string = Line 5, characters 8-11: 5 | foo ~(bar : _ @@ unique) ^^^ -Error: Found a shared value where a unique value was expected +Error: Found a aliased value where a unique value was expected |}] let x = @@ -111,7 +111,7 @@ let x = Line 3, characters 8-11: 3 | foo ~(bar @ unique) ^^^ -Error: Found a shared value where a unique value was expected +Error: Found a aliased value where a unique value was expected |}] type r = {a : string; b : string} @@ -143,7 +143,7 @@ let foo () = Line 4, characters 4-7: 4 | ~(bar:_@@unique), ~(biz:_@@once) ^^^ -Error: Found a shared value where a unique value was expected +Error: Found a aliased value where a unique value was expected |}] @@ -155,7 +155,7 @@ let foo () = Line 4, characters 4-7: 4 | ~(bar @ unique), ~(biz @ once) ^^^ -Error: Found a shared value where a unique value was expected +Error: Found a aliased value where a unique value was expected |}] *) @@ -265,36 +265,36 @@ type r = { global_ x : string; } (* Modalities don't imply each other; this will change as we add borrowing. *) type r = { - global_ x : string @@ shared + global_ x : string @@ aliased } [%%expect{| -type r = { global_ x : string @@ shared; } +type r = { global_ x : string @@ aliased; } |}] type r = { - x : string @@ shared global many + x : string @@ aliased global many } [%%expect{| -type r = { global_ x : string @@ many shared; } +type r = { global_ x : string @@ many aliased; } |}] type r = { - x : string @@ shared global many shared + x : string @@ aliased global many aliased } (* CR reduced-modality: this should warn. *) [%%expect{| -type r = { global_ x : string @@ many shared; } +type r = { global_ x : string @@ many aliased; } |}] -type r = Foo of string @@ global shared many +type r = Foo of string @@ global aliased many [%%expect{| -type r = Foo of global_ string @@ many shared +type r = Foo of global_ string @@ many aliased |}] -(* mutable implies global shared many. No warnings are given since we imagine +(* mutable implies global aliased many. No warnings are given since we imagine that the coupling will be removed soon. *) type r = { - mutable x : string @@ global shared many + mutable x : string @@ global aliased many } [%%expect{| type r = { mutable x : string; } diff --git a/ocaml/testsuite/tests/typing-modes/mutable.ml b/ocaml/testsuite/tests/typing-modes/mutable.ml index 565054e53c8..4e3c0e2507a 100644 --- a/ocaml/testsuite/tests/typing-modes/mutable.ml +++ b/ocaml/testsuite/tests/typing-modes/mutable.ml @@ -82,15 +82,15 @@ Error: This value is nonportable but expected to be portable. |}] (* This attribute doesn't disable implied modalities on monadic axes. For - example, there is a [shared] modality on the [s] field, which allows the + example, there is a [aliased] modality on the [s] field, which allows the following to type check. Otherwise, new values in mutation are required to be [unique]. *) -let foo r (s @ shared) = r.s <- s +let foo r (s @ aliased) = r.s <- s [%%expect{| val foo : 'a r -> 'a -> unit = |}] -let foo (s @ shared) = ({s} : _ @@ unique) +let foo (s @ aliased) = ({s} : _ @@ unique) [%%expect{| val foo : 'a -> 'a r = |}] @@ -100,7 +100,7 @@ let foo (r @ unique) = (r.s : _ @@ unique) Line 1, characters 24-27: 1 | let foo (r @ unique) = (r.s : _ @@ unique) ^^^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] module M : sig diff --git a/ocaml/testsuite/tests/typing-modes/val_modalities.ml b/ocaml/testsuite/tests/typing-modes/val_modalities.ml index 6b5cb6fc274..027ef5562a8 100644 --- a/ocaml/testsuite/tests/typing-modes/val_modalities.ml +++ b/ocaml/testsuite/tests/typing-modes/val_modalities.ml @@ -38,12 +38,12 @@ module M : sig val foo : r @@ global many end |}] module type S = sig - val x : string @@ global local unique shared once many uncontended contended + val x : string @@ global local unique aliased once many uncontended contended portable nonportable end [%%expect{| module type S = - sig val x : string @@ global many portable shared contended end + sig val x : string @@ global many portable aliased contended end |}] (* values' comonadic axes must be lower than the module *) diff --git a/ocaml/testsuite/tests/typing-unique/unique.ml b/ocaml/testsuite/tests/typing-unique/unique.ml index f24e805d74f..2d1bc3b77ef 100644 --- a/ocaml/testsuite/tests/typing-unique/unique.ml +++ b/ocaml/testsuite/tests/typing-unique/unique.ml @@ -106,8 +106,8 @@ let f () = val f : unit -> string = |}] -(* variables inside loops will be made both shared and many *) -(* the following is fine, because k inside loop is shared *) +(* variables inside loops will be made both aliased and many *) +(* the following is fine, because k inside loop is aliased *) let f () = let unique_ k = "foo" in for i = 1 to 5 do @@ -141,7 +141,7 @@ let f () = Line 4, characters 12-13: 4 | unique_ k ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. Hint: This identifier cannot be used uniquely, because it was defined outside of the for-loop. |}] @@ -157,7 +157,7 @@ let f = Line 5, characters 14-15: 5 | let _ = g a in () ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. Hint: This identifier cannot be used uniquely, because it was defined outside of the for-loop. |}] @@ -174,7 +174,7 @@ val f : unit = () |}] (* the following is howerver fine, because g doesn't use the uniqueness of k; -in fact, the k inside g is just shared. +in fact, the k inside g is just aliased. *) let f () = let unique_ k = "foo" in @@ -224,28 +224,28 @@ let foo y = once_ x val foo : 'a -> once_ string = |}] -(* top-level must be shared; the following unique is weakened to shared *) +(* top-level must be aliased; the following unique is weakened to aliased *) let unique_ foo = "foo" [%%expect{| val foo : string = "foo" |}] -(* the following is bad - trying to tighten shared to unique *) +(* the following is bad - trying to tighten aliased to unique *) let foo y = unique_ x [%%expect{| Line 1, characters 20-21: 1 | let foo y = unique_ x ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] -(* CR zqian: [global] should imply [shared]/[many], once we introduce borrowing whose +(* CR zqian: [global] should imply [aliased]/[many], once we introduce borrowing whose scope is controlled by locality *) -type 'a glob = { glob: 'a @@ shared many } [@@unboxed] +type 'a glob = { glob: 'a @@ aliased many } [@@unboxed] [%%expect{| -type 'a glob = { glob : 'a @@ many shared; } [@@unboxed] +type 'a glob = { glob : 'a @@ many aliased; } [@@unboxed] |}] let dup (glob : 'a) : 'a glob * 'a glob = unique_ ({glob}, {glob}) [%%expect{| @@ -269,9 +269,9 @@ let unique_id : 'a. unique_ 'a -> unique_ 'a = fun x -> x val unique_id : unique_ 'a -> unique_ 'a = |}] -let shared_id : 'a -> 'a = fun x -> x +let aliased_id : 'a -> 'a = fun x -> x [%%expect{| -val shared_id : 'a -> 'a = +val aliased_id : 'a -> 'a = |}] let tail_unique _x = @@ -302,15 +302,15 @@ let higher_order3 (f : 'a -> 'b) (unique_ x : 'a) = unique_ f x Line 1, characters 60-63: 1 | let higher_order3 (f : 'a -> 'b) (unique_ x : 'a) = unique_ f x ^^^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] -let higher_order4 (f : unique_ 'a -> 'b) (x : 'a) = f (shared_id x) +let higher_order4 (f : unique_ 'a -> 'b) (x : 'a) = f (aliased_id x) [%%expect{| -Line 1, characters 54-67: -1 | let higher_order4 (f : unique_ 'a -> 'b) (x : 'a) = f (shared_id x) - ^^^^^^^^^^^^^ -Error: This value is shared but expected to be unique. +Line 1, characters 54-68: +1 | let higher_order4 (f : unique_ 'a -> 'b) (x : 'a) = f (aliased_id x) + ^^^^^^^^^^^^^^ +Error: This value is aliased but expected to be unique. |}] let higher_order5 (unique_ x) = let f (unique_ x) = unique_ x in higher_order f x @@ -351,24 +351,24 @@ val inf2 : bool -> unique_ float -> float = |}] let inf3 : bool -> float -> unique_ float -> float = fun b y x -> - let _ = shared_id y in let unique_ z = if b then x else y in z + let _ = aliased_id y in let unique_ z = if b then x else y in z [%%expect{| -Line 2, characters 58-59: -2 | let _ = shared_id y in let unique_ z = if b then x else y in z - ^ -Error: This value is shared but expected to be unique. +Line 2, characters 59-60: +2 | let _ = aliased_id y in let unique_ z = if b then x else y in z + ^ +Error: This value is aliased but expected to be unique. |}] let inf4 (b : bool) (y : float) (unique_ x : float) = - let _ = shared_id y in let unique_ z = if b then x else y in z + let _ = aliased_id y in let unique_ z = if b then x else y in z [%%expect{| -Line 2, characters 58-59: -2 | let _ = shared_id y in let unique_ z = if b then x else y in z - ^ +Line 2, characters 59-60: +2 | let _ = aliased_id y in let unique_ z = if b then x else y in z + ^ Error: This value is used here as unique, but it has already been used: -Line 2, characters 20-21: -2 | let _ = shared_id y in let unique_ z = if b then x else y in z - ^ +Line 2, characters 21-22: +2 | let _ = aliased_id y in let unique_ z = if b then x else y in z + ^ |}] @@ -577,7 +577,7 @@ val no_curry : unique_ box -> (unique_ box -> unit) = (* If both type and mode are wrong, complain about type *) let f () = - let id2 (x : string) = shared_id x in + let id2 (x : string) = aliased_id x in let unique_ r = 42 in id2 r [%%expect{| diff --git a/ocaml/testsuite/tests/typing-unique/unique_analysis.ml b/ocaml/testsuite/tests/typing-unique/unique_analysis.ml index 8a8db6e03eb..2eb8bb0e4e5 100644 --- a/ocaml/testsuite/tests/typing-unique/unique_analysis.ml +++ b/ocaml/testsuite/tests/typing-unique/unique_analysis.ml @@ -13,9 +13,9 @@ let unique_id : 'a. unique_ 'a -> unique_ 'a = fun x -> x val unique_id : unique_ 'a -> unique_ 'a = |}] -let shared_id : 'a -> 'a = fun x -> x +let aliased_id : 'a -> 'a = fun x -> x [%%expect{| -val shared_id : 'a -> 'a = +val aliased_id : 'a -> 'a = |}] let ignore_once: once_ 'a -> unit = fun x -> () @@ -188,7 +188,7 @@ let or_patterns1 : unique_ float list -> float list -> float = Line 3, characters 37-38: 3 | | z :: _, _ | _, z :: _ -> unique_ z ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] let or_patterns2 : float list -> unique_ float list -> float = @@ -199,7 +199,7 @@ let or_patterns2 : float list -> unique_ float list -> float = Line 3, characters 37-38: 3 | | z :: _, _ | _, z :: _ -> unique_ z ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. |}] let or_patterns3 p = @@ -242,7 +242,7 @@ Line 4, characters 50-51: (* for some reason the following error message is missing "another use". Don't know what's wrong *) -let mark_top_shared = +let mark_top_aliased = let unique_ xs = 2 :: 3 :: [] in match xs with | x :: xx -> @@ -261,7 +261,7 @@ Line 5, characters 24-26: |}] -let mark_top_shared = +let mark_top_aliased = let unique_ xs = 2 :: 3 :: [] in let _ = unique_id xs in match xs with @@ -278,19 +278,19 @@ Line 3, characters 20-22: |}] -let mark_shared_in_one_branch b x = +let mark_aliased_in_one_branch b x = if b then unique_id (x, 3.0) else (x, x) [%%expect{| -val mark_shared_in_one_branch : bool -> unique_ float -> float * float = +val mark_aliased_in_one_branch : bool -> unique_ float -> float * float = |}] -let mark_shared_in_one_branch b x = +let mark_aliased_in_one_branch b x = if b then (x, x) else unique_id (x, 3.0) [%%expect{| -val mark_shared_in_one_branch : bool -> unique_ float -> float * float = +val mark_aliased_in_one_branch : bool -> unique_ float -> float * float = |}] @@ -327,7 +327,7 @@ Line 3, characters 40-41: let tuple_parent_marked a b = match (a, b) with - | (_, b) as _t -> shared_id b + | (_, b) as _t -> aliased_id b [%%expect{| val tuple_parent_marked : 'a -> 'b -> 'b = |}] @@ -339,7 +339,7 @@ val tuple_parent_marked : 'a -> 'b -> 'b = let tuple_parent_marked a b = match (a, b) with | (true, b') -> unique_id b' - | (false, b') as _t -> shared_id b' + | (false, b') as _t -> aliased_id b' [%%expect{| Line 3, characters 28-30: 3 | | (true, b') -> unique_id b' @@ -353,7 +353,7 @@ Line 2, characters 12-13: let tuple_parent_marked a b = match (a, b) with - | (false, b) as _t -> shared_id b + | (false, b) as _t -> aliased_id b | (true, b) -> unique_id b [%%expect{| Line 4, characters 27-28: @@ -552,7 +552,7 @@ let foo () = let x = {a = "hello"; b = "world"} in ignore (unique_id x.b); x.a <- "olleh"; - ignore (shared_id x.a) + ignore (aliased_id x.a) [%%expect{| val foo : unit -> unit = |}] @@ -570,16 +570,16 @@ module Value : sig type t val mk : unit -> unique_ t end |}] (* Testing modalities in records *) -type r_shared = {x : Value.t; y : Value.t @@ shared many} +type r_aliased = {x : Value.t; y : Value.t @@ aliased many} [%%expect{| -type r_shared = { x : Value.t; y : Value.t @@ many shared; } +type r_aliased = { x : Value.t; y : Value.t @@ many aliased; } |}] let foo () = let r = {x = Value.mk (); y = Value.mk ()} in - ignore (shared_id r.y); + ignore (aliased_id r.y); (* the following is allowed, because using r uniquely implies using r.x - shared *) + aliased *) ignore (unique_id r) [%%expect{| val foo : unit -> unit = @@ -612,7 +612,7 @@ Line 3, characters 14-17: let foo () = let r = {x = Value.mk (); y = Value.mk ()} in - ignore (shared_id r.x); + ignore (aliased_id r.x); (* doesn't work for normal fields *) ignore (unique_id r) [%%expect{| @@ -621,9 +621,9 @@ Line 5, characters 20-21: ^ Error: This value is used here as unique, but part of it has already been used: -Line 3, characters 20-23: -3 | ignore (shared_id r.x); - ^^^ +Line 3, characters 21-24: +3 | ignore (aliased_id r.x); + ^^^ |}] @@ -631,7 +631,7 @@ Line 3, characters 20-23: let foo () = let r = {x = Value.mk (); y = Value.mk ()} in ignore (unique_ {r with x = Value.mk ()}); - (* r.y has been used shared; in the following we will use r as unique *) + (* r.y has been used aliased; in the following we will use r as unique *) ignore (unique_id r) [%%expect{| val foo : unit -> unit = @@ -655,17 +655,17 @@ Line 3, characters 19-20: |}] (* testing modalities in constructors *) -type r_shared = R_shared of Value.t * Value.t @@ shared many +type r_aliased = R_aliased of Value.t * Value.t @@ aliased many [%%expect{| -type r_shared = R_shared of Value.t * Value.t @@ many shared +type r_aliased = R_aliased of Value.t * Value.t @@ many aliased |}] let foo () = - let r = R_shared (Value.mk (), Value.mk ()) in - let R_shared (_, y) = r in - ignore (shared_id y); + let r = R_aliased (Value.mk (), Value.mk ()) in + let R_aliased (_, y) = r in + ignore (aliased_id y); (* the following is allowed, because using r uniquely implies using r.x - shared *) + aliased *) ignore (unique_id r) [%%expect{| val foo : unit -> unit = @@ -673,8 +673,8 @@ val foo : unit -> unit = (* Similarly for linearity *) let foo () = - let r = once_ (R_shared (Value.mk (), Value.mk ())) in - let R_shared (_, y) = r in + let r = once_ (R_aliased (Value.mk (), Value.mk ())) in + let R_aliased (_, y) = r in ignore_once y; ignore_once r; [%%expect{| @@ -682,8 +682,8 @@ val foo : unit -> unit = |}] let foo () = - let r = once_ (R_shared (Value.mk (), Value.mk ())) in - let R_shared (x, _) = r in + let r = once_ (R_aliased (Value.mk (), Value.mk ())) in + let R_aliased (x, _) = r in ignore_once x; ignore_once r; [%%expect{| @@ -699,9 +699,9 @@ Line 4, characters 14-15: |}] let foo () = - let r = R_shared (Value.mk (), Value.mk ()) in - let R_shared (x, _) = r in - ignore (shared_id x); + let r = R_aliased (Value.mk (), Value.mk ()) in + let R_aliased (x, _) = r in + ignore (aliased_id x); (* doesn't work for normal fields *) ignore (unique_id r) [%%expect{| @@ -710,9 +710,9 @@ Line 6, characters 20-21: ^ Error: This value is used here as unique, but part of it has already been used: -Line 4, characters 20-21: -4 | ignore (shared_id x); - ^ +Line 4, characters 21-22: +4 | ignore (aliased_id x); + ^ |}] @@ -745,7 +745,7 @@ type r = {x : float; y : float} (* CR zqian: The following should pass but doesn't, because the uniqueness analysis doesn't support mode crossing. The following involes sequencing the maybe_unique usage of [r.x] and the maybe_unique usage of [r] as a whole. - Sequencing them will force both to be shared and many. The [unique_use] in + Sequencing them will force both to be aliased and many. The [unique_use] in [r.x] is mode-crossed (being an unboxed float) so is fine. The [unique_use] in [r] cannot cross mode, and forcing it causes error. *) diff --git a/ocaml/testsuite/tests/typing-unique/unique_mod_class.ml b/ocaml/testsuite/tests/typing-unique/unique_mod_class.ml index 5da70aaad20..1fb3b1b9a73 100644 --- a/ocaml/testsuite/tests/typing-unique/unique_mod_class.ml +++ b/ocaml/testsuite/tests/typing-unique/unique_mod_class.ml @@ -19,12 +19,12 @@ val unique_id : unique_ 'a -> unit = Line 8, characters 20-21: 8 | val bar = unique_ x ^ -Error: This value is shared but expected to be unique. +Error: This value is aliased but expected to be unique. Hint: This identifier cannot be used uniquely, because it is defined in a class. |}] -(* you can use env vars as shared and many, but they might collide with the external uses *) +(* you can use env vars as aliased and many, but they might collide with the external uses *) let texp_object () = let x = "foo" in unique_id x; @@ -54,11 +54,11 @@ let texp_letmodule () = Line 4, characters 12-21: 4 | let y = unique_ x ^^^^^^^^^ -Error: This value is shared but used as unique. +Error: This value is aliased but used as unique. Hint: This value comes from outside the current module or class. |}] -(* you can use x as shared and many, but it might collide with external uses. *) +(* you can use x as aliased and many, but it might collide with external uses. *) let texp_letmodule () = let x = "foo" in unique_id x; @@ -86,7 +86,7 @@ let texp_open () = Line 3, characters 27-36: 3 | let open (struct let y = unique_ x end) in ^^^^^^^^^ -Error: This value is shared but used as unique. +Error: This value is aliased but used as unique. Hint: This value comes from outside the current module or class. |}] @@ -117,7 +117,7 @@ module type bar = sig val y : string end Line 5, characters 33-42: 5 | let z = (module struct let y = unique_ x end : bar) in ^^^^^^^^^ -Error: This value is shared but used as unique. +Error: This value is aliased but used as unique. Hint: This value comes from outside the current module or class. |}] @@ -149,5 +149,5 @@ module M : sig val foo : string end Line 7, characters 12-17: 7 | unique_id M.foo ^^^^^ -Error: This value is shared but expected to be unique. -|}] \ No newline at end of file +Error: This value is aliased but expected to be unique. +|}] diff --git a/ocaml/testsuite/tests/typing-unique/unique_typedecl.ml b/ocaml/testsuite/tests/typing-unique/unique_typedecl.ml index 9ee8af340c9..4b3799e67a6 100644 --- a/ocaml/testsuite/tests/typing-unique/unique_typedecl.ml +++ b/ocaml/testsuite/tests/typing-unique/unique_typedecl.ml @@ -25,7 +25,7 @@ constraint type equ_fn = unit |}] -(* uniqueness of closures are by default shared, +(* uniqueness of closures are by default aliased, regardless of anything; unique would be better except for some backward compatibility issues *) type equ_fn = unit @@ -67,4 +67,4 @@ Line 1, characters 42-89: Error: The type constraints are not consistent. Type unique_ int -> int is not compatible with type unique_ int -> unique_ int -|}] \ No newline at end of file +|}] diff --git a/ocaml/typing/ctype.ml b/ocaml/typing/ctype.ml index 54c951b831c..e10732524ef 100644 --- a/ocaml/typing/ctype.ml +++ b/ocaml/typing/ctype.ml @@ -1210,7 +1210,7 @@ let rec copy ?partial ?keep_names copy_scope ty = tions belonging to different branches of a type are independent. Moreover, a reference containing a [Mcons] must be - shared, so that the memorized expansion of an abbrevi- + aliased, so that the memorized expansion of an abbrevi- ation can be released by changing the content of just one reference. *) @@ -1526,7 +1526,7 @@ let copy_sep ~copy_scope ~fixed ~(visited : type_expr TypeHash.t) sch = copy_row (copy_rec ~may_share:true) fixed' row keep more' in Tvariant row | Tfield (p, k, ty1, ty2) -> - (* the kind is kept shared, see Btype.copy_type_desc *) + (* the kind is kept aliased, see Btype.copy_type_desc *) Tfield (p, field_kind_internal_repr k, copy_rec ~may_share:true ty1, copy_rec ~may_share:false ty2) @@ -1597,7 +1597,7 @@ let curry_mode alloc arg : Alloc.Const.t = (Alloc.Const.close_over arg) (Alloc.Const.partial_apply alloc) in - (* For A -> B -> C, we always interpret (B -> C) to be of shared. This is the + (* For A -> B -> C, we always interpret (B -> C) to be of aliased. This is the legacy mode which helps with legacy compatibility. Arrow types cross uniqueness so we are not losing too much expressvity here. One counter-example is: @@ -1607,10 +1607,10 @@ let curry_mode alloc arg : Alloc.Const.t = And [f g] would not work, as mode crossing doesn't work deeply into arrows. Our answer to this issue is that, the author of f shouldn't ask B -> C to be - unique_. Instead, they should leave it as default which is shared, and mode + unique_. Instead, they should leave it as default which is aliased, and mode crossing it to unique at the location where B -> C is a real value (instead of the return of a function). *) - {acc with uniqueness=Uniqueness.Const.Shared} + {acc with uniqueness=Uniqueness.Const.Aliased} let rec instance_prim_locals locals mvar macc finalret ty = match locals, get_desc ty with diff --git a/ocaml/typing/env.ml b/ocaml/typing/env.ml index 679bc4a6589..d1c2ff7a641 100644 --- a/ocaml/typing/env.ml +++ b/ocaml/typing/env.ml @@ -3044,7 +3044,7 @@ let share_mode ~errors ~env ~loc ~item ~lid vmode shared_context = (Once_value_used_in (item, lid, shared_context)) | Ok () -> let mode = - Mode.Value.join_with (Monadic Uniqueness) Mode.Uniqueness.Const.Shared + Mode.Value.join_with (Monadic Uniqueness) Mode.Uniqueness.Const.Aliased vmode.mode in {mode; context = Some shared_context} @@ -4023,7 +4023,7 @@ let sharedness_hint ppf : shared_context -> _ = function Format.fprintf ppf "@[Hint: This identifier was defined outside of the current closure.@ \ Either this closure has to be once, or the identifier can be used only@ \ - as shared.@]" + as aliased.@]" | Module -> Format.fprintf ppf "@[Hint: This identifier cannot be used uniquely,@ \ diff --git a/ocaml/typing/mode.ml b/ocaml/typing/mode.ml index 5e7927cf0e3..362d57c262a 100644 --- a/ocaml/typing/mode.ml +++ b/ocaml/typing/mode.ml @@ -177,34 +177,34 @@ module Lattices = struct module Uniqueness = struct type t = | Unique - | Shared + | Aliased include Total (struct type nonrec t = t let min = Unique - let max = Shared + let max = Aliased - let legacy = Shared + let legacy = Aliased let le a b = match a, b with - | Unique, _ | _, Shared -> true - | Shared, Unique -> false + | Unique, _ | _, Aliased -> true + | Aliased, Unique -> false let join a b = match a, b with - | Shared, _ | _, Shared -> Shared + | Aliased, _ | _, Aliased -> Aliased | Unique, Unique -> Unique let meet a b = match a, b with | Unique, _ | _, Unique -> Unique - | Shared, Shared -> Shared + | Aliased, Aliased -> Aliased let print ppf = function - | Shared -> Format.fprintf ppf "shared" + | Aliased -> Format.fprintf ppf "aliased" | Unique -> Format.fprintf ppf "unique" end) end @@ -867,12 +867,12 @@ module Lattices_mono = struct let id = Id let linear_to_unique = function - | Linearity.Many -> Uniqueness.Shared + | Linearity.Many -> Uniqueness.Aliased | Linearity.Once -> Uniqueness.Unique let unique_to_linear = function | Uniqueness.Unique -> Linearity.Once - | Uniqueness.Shared -> Linearity.Many + | Uniqueness.Aliased -> Linearity.Many let portable_to_contended = function | Portability.Portable -> Contention.Contended @@ -1448,7 +1448,7 @@ module Uniqueness = struct include Common (Obj) - let shared = of_const Shared + let aliased = of_const Aliased let unique = of_const Unique diff --git a/ocaml/typing/mode_intf.mli b/ocaml/typing/mode_intf.mli index 857e6f90c40..3a5de47c81c 100644 --- a/ocaml/typing/mode_intf.mli +++ b/ocaml/typing/mode_intf.mli @@ -224,7 +224,7 @@ module type S = sig module Const : sig type t = | Unique - | Shared + | Aliased include Lattice with type t := t end @@ -237,7 +237,7 @@ module type S = sig and type error := error and type 'd t = (Const.t, 'd) mode_monadic - val shared : lr + val aliased : lr val unique : lr end diff --git a/ocaml/typing/typeclass.ml b/ocaml/typing/typeclass.ml index f3444e2d377..725d5855ba3 100644 --- a/ocaml/typing/typeclass.ml +++ b/ocaml/typing/typeclass.ml @@ -1253,7 +1253,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = (id, {exp_desc = Texp_ident(path, mknoloc (Longident.Lident (Ident.name id)), vd, - Id_value, shared_many_use); + Id_value, aliased_many_use); exp_loc = Location.none; exp_extra = []; exp_type = Ctype.instance vd.val_type; exp_attributes = []; (* check *) @@ -1456,7 +1456,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl = let expr = {exp_desc = Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd, - Id_value, shared_many_use); + Id_value, aliased_many_use); exp_loc = Location.none; exp_extra = []; exp_type = ty; exp_attributes = []; diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index 10189d5ffdc..4b93626adb1 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -2401,7 +2401,7 @@ let check_scope_escape loc env level ty = The solution is to pass a GADT tag to [type_pat] to indicate whether a value or computation pattern is expected. This way, there is a single - place where [Ppat_or] nodes are type-checked, the checking logic is shared, + place where [Ppat_or] nodes are type-checked, the checking logic is aliased, and only at the end do we inspect the tag to decide to produce a value or computation pattern. *) @@ -4757,9 +4757,9 @@ let unique_use ~loc ~env mode_l mode_r = let linearity = Linearity.disallow_right (Value.proj (Comonadic Linearity) mode_l) in if not (Language_extension.is_enabled Unique) then begin (* if unique extension is not enabled, we will not run uniqueness analysis; - instead, we force all uses to be shared and many. This is equivalent to + instead, we force all uses to be aliased and many. This is equivalent to running a UA which forces everything *) - (match Uniqueness.submode Uniqueness.shared uniqueness with + (match Uniqueness.submode Uniqueness.aliased uniqueness with | Ok () -> () | Error e -> let e : Mode.Value.error = Error (Monadic Uniqueness, e) in @@ -4771,7 +4771,7 @@ let unique_use ~loc ~env mode_l mode_r = let e : Mode.Value.error = Error (Comonadic Linearity, e) in raise (Error (loc, env, Submode_failed(e, Other, None, None, None))) ); - (Uniqueness.disallow_left Uniqueness.shared, + (Uniqueness.disallow_left Uniqueness.aliased, Linearity.disallow_right Linearity.many) end else (uniqueness, linearity) diff --git a/ocaml/typing/typedtree.ml b/ocaml/typing/typedtree.ml index 06988227369..d0a0023a08c 100644 --- a/ocaml/typing/typedtree.ml +++ b/ocaml/typing/typedtree.ml @@ -63,8 +63,8 @@ type texp_field_boxing = | Boxing of alloc_mode * unique_use | Non_boxing of unique_use -let shared_many_use = - ( Mode.Uniqueness.disallow_left Mode.Uniqueness.shared, +let aliased_many_use = + ( Mode.Uniqueness.disallow_left Mode.Uniqueness.aliased, Mode.Linearity.disallow_right Mode.Linearity.many ) type pattern = value general_pattern diff --git a/ocaml/typing/typedtree.mli b/ocaml/typing/typedtree.mli index a203f92d916..c2abd9c67c8 100644 --- a/ocaml/typing/typedtree.mli +++ b/ocaml/typing/typedtree.mli @@ -67,7 +67,7 @@ type _ pattern_category = (** Access mode for a field projection, represented by the usage of the record immediately following the projection. If the following usage is unique, the projection must be borrowed and cannot be moved. If the following usage is - shared, the projection can be shared and moved. *) + aliased, the projection can be aliased and moved. *) type unique_barrier = Mode.Uniqueness.r type unique_use = Mode.Uniqueness.r * Mode.Linearity.l @@ -85,7 +85,7 @@ type texp_field_boxing = (** Projection does not require boxing. [unique_use] describes the usage of the field as the result of direct projection. *) -val shared_many_use : unique_use +val aliased_many_use : unique_use type pattern = value general_pattern and 'k general_pattern = 'k pattern_desc pattern_data diff --git a/ocaml/typing/typemode.ml b/ocaml/typing/typemode.ml index 3af32f3fdda..f1825b7d901 100644 --- a/ocaml/typing/typemode.ml +++ b/ocaml/typing/typemode.ml @@ -34,7 +34,7 @@ module Axis_pair = struct | "local" -> Any_axis_pair (Modal Locality, Locality.Const.Local) | "global" -> Any_axis_pair (Modal Locality, Locality.Const.Global) | "unique" -> Any_axis_pair (Modal Uniqueness, Uniqueness.Const.Unique) - | "shared" -> Any_axis_pair (Modal Uniqueness, Uniqueness.Const.Shared) + | "aliased" -> Any_axis_pair (Modal Uniqueness, Uniqueness.Const.Aliased) | "once" -> Any_axis_pair (Modal Linearity, Linearity.Const.Once) | "many" -> Any_axis_pair (Modal Linearity, Linearity.Const.Many) | "nonportable" -> @@ -162,7 +162,7 @@ let untransl_modality (a : Modality.t) : Parsetree.modality loc = | Atom (Comonadic Areality, Meet_with Regionality.Const.Local) -> "local" | Atom (Comonadic Linearity, Meet_with Linearity.Const.Many) -> "many" | Atom (Comonadic Linearity, Meet_with Linearity.Const.Once) -> "once" - | Atom (Monadic Uniqueness, Join_with Uniqueness.Const.Shared) -> "shared" + | Atom (Monadic Uniqueness, Join_with Uniqueness.Const.Aliased) -> "aliased" | Atom (Monadic Uniqueness, Join_with Uniqueness.Const.Unique) -> "unique" | Atom (Comonadic Portability, Meet_with Portability.Const.Portable) -> "portable" diff --git a/ocaml/typing/uniqueness_analysis.ml b/ocaml/typing/uniqueness_analysis.ml index 2e9492b70ea..c532e83daeb 100644 --- a/ocaml/typing/uniqueness_analysis.ml +++ b/ocaml/typing/uniqueness_analysis.ml @@ -35,7 +35,7 @@ let rec iter_error f = function | x :: xs -> ( match f x with Ok () -> iter_error f xs | Error e -> Error e) module Maybe_unique : sig - (** The type representing a usage that could be either unique or shared *) + (** The type representing a usage that could be either unique or aliased *) type t (** extract an arbitrary occurrence from this usage *) @@ -50,7 +50,7 @@ module Maybe_unique : sig | Uniqueness | Linearity - (** Describes why cannot force shared - including the failing occurrence, and + (** Describes why cannot force aliased - including the failing occurrence, and the failing axis *) type cannot_force = { occ : Occurrence.t; @@ -62,17 +62,17 @@ module Maybe_unique : sig (** Returns the uniqueness represented by this usage. If this identifier is expected to be unique in any branch, it will return unique. If the current - usage is forced, it will return shared. *) + usage is forced, it will return aliased. *) val uniqueness : t -> Uniqueness.r end = struct - (** Occurrences with modes to be forced shared and many in the future if + (** Occurrences with modes to be forced aliased and many in the future if needed. This is a list because of multiple control flows. For example, if - a value is used shared in one branch but unique in another branch, then + a value is used aliased in one branch but unique in another branch, then overall the value is used uniquely (this is a "stricter" requirement). Therefore, techincally, the mode this list represents is the meet of all - modes in the lists. (recall that shared > unique). Therefore, if this - virtual mode needs to be forced shared, the whole list needs to be forced - shared. *) + modes in the lists. (recall that aliased > unique). Therefore, if this + virtual mode needs to be forced aliased, the whole list needs to be forced + aliased. *) type t = (unique_use * Occurrence.t) list let singleton unique_use occ : t = [unique_use, occ] @@ -91,12 +91,12 @@ end = struct let mark_multi_use l = let force_one ((uni, lin), occ) = (* values being multi-used means two things: - - the expected mode must be higher than [shared] + - the expected mode must be higher than [aliased] - the access mode must be lower than [many] *) match Linearity.submode lin Linearity.many with | Error _ -> Error { occ; axis = Linearity } | Ok () -> ( - match Uniqueness.submode Uniqueness.shared uni with + match Uniqueness.submode Uniqueness.aliased uni with | Ok () -> Ok () | Error _ -> Error { occ; axis = Uniqueness }) in @@ -107,7 +107,7 @@ end = struct let meet l0 l1 = l0 @ l1 end -module Maybe_shared : sig +module Maybe_aliased : sig type t type access = @@ -116,7 +116,7 @@ module Maybe_shared : sig val string_of_access : access -> string - (** The type representing a usage that could be either shared or borrowed *) + (** The type representing a usage that could be either aliased or borrowed *) (** Extract an arbitrary occurrence from the usage *) val extract_occurrence_access : t -> Occurrence.t * access @@ -124,7 +124,7 @@ module Maybe_shared : sig (** Add a barrier. The uniqueness mode represents the usage immediately following the current usage. If that mode is Unique, the current usage must be Borrowed (hence no code motion); if that mode is not restricted - to Unique, this usage can be Borrowed or Shared (prefered). Can be called + to Unique, this usage can be Borrowed or Aliased (prefered). Can be called multiple times for multiple barriers (for different branches). *) val add_barrier : t -> Uniqueness.r -> unit @@ -140,9 +140,9 @@ end = struct (** list of occurences together with modes to be forced as borrowed in the future if needed. It is a list because of multiple control flows. For - example, if a value is used borrowed in one branch but shared in another, - then the overall usage is shared. Therefore, the mode this list represents - is the meet of all modes in the list. (recall that borrowed > shared). + example, if a value is used borrowed in one branch but aliased in another, + then the overall usage is aliased. Therefore, the mode this list represents + is the meet of all modes in the list. (recall that borrowed > aliased). Therefore, if this virtual mode needs to be forced borrowed, the whole list needs to be forced borrowed. *) type t = (unique_barrier ref * Occurrence.t * access) list @@ -161,14 +161,14 @@ end = struct t end -module Shared : sig +module Aliased : sig type t type reason = - | Forced (** shared because forced *) - | Lazy (** shared because it is the argument of lazy forcing *) - | Lifted of Maybe_shared.access - (** shared because lifted from implicit borrowing, carries the original + | Forced (** aliased because forced *) + | Lazy (** aliased because it is the argument of lazy forcing *) + | Lifted of Maybe_aliased.access + (** aliased because lifted from implicit borrowing, carries the original access *) (** The occurrence is only for future error messages. The share_reason must @@ -182,7 +182,7 @@ end = struct type reason = | Forced | Lazy - | Lifted of Maybe_shared.access + | Lifted of Maybe_aliased.access type t = Occurrence.t * reason @@ -200,13 +200,13 @@ module Usage : sig (** A borrowed usage with an arbitrary occurrence. The occurrence is only for future error messages. Currently not used, because we don't have explicit borrowing *) - | Maybe_shared of Maybe_shared.t - (** A usage that could be either borrowed or shared. *) - | Shared of Shared.t (** A shared usage *) + | Maybe_aliased of Maybe_aliased.t + (** A usage that could be either borrowed or aliased. *) + | Aliased of Aliased.t (** A aliased usage *) | Maybe_unique of Maybe_unique.t - (** A usage that could be either unique or shared. *) + (** A usage that could be either unique or aliased. *) - val shared : Occurrence.t -> Shared.reason -> t + val aliased : Occurrence.t -> Aliased.reason -> t val maybe_unique : unique_use -> Occurrence.t -> t @@ -235,11 +235,11 @@ module Usage : sig (** Parallel composition *) val par : t -> t -> t end = struct - (* We have Unused (top) > Borrowed > Shared > Unique > Error (bot). + (* We have Unused (top) > Borrowed > Aliased > Unique > Error (bot). - Unused means unused - Borrowed means read-only access confined to a region - - Shared means read-only access that may escape a region. For example, + - Aliased means read-only access that may escape a region. For example, storing the value in a cell that can be accessed later. - Unique means accessing the value as if it's the only pointer. Example includes overwriting. @@ -248,17 +248,17 @@ end = struct Some observations: - It is sound to relax mode towards Error. It grants the access more "capability" and usually helps performance. - For example, relaxing borrowed to shared allows code motion of - projections. Relaxing shared to unique allows in-place update. + For example, relaxing borrowed to aliased allows code motion of + projections. Relaxing aliased to unique allows in-place update. - An example of the relaxing borrowed to shared: + An example of the relaxing borrowed to aliased: let x = r.a in (a lot of codes) x In first line, r.memory_address is accessed as borrowed. But if we weaken - it to shared and it still mode checks, that means + it to aliased and it still mode checks, that means - there is no "unique" access in the "a lot of codes" - or equivalently, that r.memory_address stays unchanged and safe to read @@ -272,16 +272,16 @@ end = struct mode for each use, such that we get the best performance, while still type-check. Currently there are really only two choices worth figuring out, Namely - - borrowed or shared? - - shared or unique? + - borrowed or aliased? + - aliased or unique? As a result, instead of having full-range inference, we only care about the following ranges: - unused - borrowed (Currently not useful, because we don't have explicit borrowing) - - borrowed or shared - - shared - - shared or unique + - borrowed or aliased + - aliased + - aliased or unique - error error is represented as exception which is just easier. @@ -290,11 +290,11 @@ end = struct type t = | Unused | Borrowed of Occurrence.t - | Maybe_shared of Maybe_shared.t - | Shared of Shared.t + | Maybe_aliased of Maybe_aliased.t + | Aliased of Aliased.t | Maybe_unique of Maybe_unique.t - let shared occ reason = Shared (Shared.singleton occ reason) + let aliased occ reason = Aliased (Aliased.singleton occ reason) let maybe_unique unique_use occ = Maybe_unique (Maybe_unique.singleton unique_use occ) @@ -302,17 +302,18 @@ end = struct let extract_occurrence = function | Unused -> None | Borrowed occ -> Some occ - | Maybe_shared t -> Some (Maybe_shared.extract_occurrence_access t |> fst) - | Shared t -> Some (Shared.extract_occurrence t) + | Maybe_aliased t -> Some (Maybe_aliased.extract_occurrence_access t |> fst) + | Aliased t -> Some (Aliased.extract_occurrence t) | Maybe_unique t -> Some (Maybe_unique.extract_occurrence t) let choose m0 m1 = match m0, m1 with | Unused, m | m, Unused -> m | Borrowed _, t | t, Borrowed _ -> t - | Maybe_shared l0, Maybe_shared l1 -> Maybe_shared (Maybe_shared.meet l0 l1) - | Maybe_shared _, t | t, Maybe_shared _ -> t - | Shared _, t | t, Shared _ -> t + | Maybe_aliased l0, Maybe_aliased l1 -> + Maybe_aliased (Maybe_aliased.meet l0 l1) + | Maybe_aliased _, t | t, Maybe_aliased _ -> t + | Aliased _, t | t, Aliased _ -> t | Maybe_unique l0, Maybe_unique l1 -> Maybe_unique (Maybe_unique.meet l0 l1) type first_or_second = @@ -327,7 +328,7 @@ end = struct exception Error of error - let force_shared_multiuse t there first_or_second = + let force_aliased_multiuse t there first_or_second = match Maybe_unique.mark_multi_use t with | Ok () -> () | Error cannot_force -> @@ -337,97 +338,100 @@ end = struct match m0, m1 with | Unused, m | m, Unused -> m | Borrowed occ, Borrowed _ -> Borrowed occ - | Borrowed _, Maybe_shared t | Maybe_shared t, Borrowed _ -> Maybe_shared t - | Borrowed _, Shared t | Shared t, Borrowed _ -> Shared t + | Borrowed _, Maybe_aliased t | Maybe_aliased t, Borrowed _ -> + Maybe_aliased t + | Borrowed _, Aliased t | Aliased t, Borrowed _ -> Aliased t | Borrowed occ, Maybe_unique t | Maybe_unique t, Borrowed occ -> - force_shared_multiuse t (Borrowed occ) First; - shared (Maybe_unique.extract_occurrence t) Shared.Forced - | Maybe_shared t0, Maybe_shared t1 -> Maybe_shared (Maybe_shared.meet t0 t1) - | Maybe_shared _, Shared occ | Shared occ, Maybe_shared _ -> + force_aliased_multiuse t (Borrowed occ) First; + aliased (Maybe_unique.extract_occurrence t) Aliased.Forced + | Maybe_aliased t0, Maybe_aliased t1 -> + Maybe_aliased (Maybe_aliased.meet t0 t1) + | Maybe_aliased _, Aliased occ | Aliased occ, Maybe_aliased _ -> (* The barrier stays empty; if there is any unique after this, it will error *) - Shared occ - | Maybe_shared t0, Maybe_unique t1 | Maybe_unique t1, Maybe_shared t0 -> - (* t1 must be shared *) - force_shared_multiuse t1 (Maybe_shared t0) First; + Aliased occ + | Maybe_aliased t0, Maybe_unique t1 | Maybe_unique t1, Maybe_aliased t0 -> + (* t1 must be aliased *) + force_aliased_multiuse t1 (Maybe_aliased t0) First; (* The barrier stays empty; if there is any unique after this, it will error *) - shared (Maybe_unique.extract_occurrence t1) Shared.Forced - | Shared t0, Shared _ -> Shared t0 - | Shared t0, Maybe_unique t1 -> - force_shared_multiuse t1 (Shared t0) Second; - Shared t0 - | Maybe_unique t1, Shared t0 -> - force_shared_multiuse t1 (Shared t0) First; - Shared t0 + aliased (Maybe_unique.extract_occurrence t1) Aliased.Forced + | Aliased t0, Aliased _ -> Aliased t0 + | Aliased t0, Maybe_unique t1 -> + force_aliased_multiuse t1 (Aliased t0) Second; + Aliased t0 + | Maybe_unique t1, Aliased t0 -> + force_aliased_multiuse t1 (Aliased t0) First; + Aliased t0 | Maybe_unique t0, Maybe_unique t1 -> - force_shared_multiuse t0 m1 First; - force_shared_multiuse t1 m0 Second; - shared (Maybe_unique.extract_occurrence t0) Shared.Forced + force_aliased_multiuse t0 m1 First; + force_aliased_multiuse t1 m0 Second; + aliased (Maybe_unique.extract_occurrence t0) Aliased.Forced let seq m0 m1 = match m0, m1 with | Unused, m | m, Unused -> m | Borrowed _, t -> t - | Maybe_shared _, Borrowed _ -> m0 - | Maybe_shared l0, Maybe_shared l1 -> Maybe_shared (Maybe_shared.meet l0 l1) - | Maybe_shared _, Shared _ -> m1 - | Maybe_shared l0, Maybe_unique l1 -> + | Maybe_aliased _, Borrowed _ -> m0 + | Maybe_aliased l0, Maybe_aliased l1 -> + Maybe_aliased (Maybe_aliased.meet l0 l1) + | Maybe_aliased _, Aliased _ -> m1 + | Maybe_aliased l0, Maybe_unique l1 -> (* Four cases (semi-colon meaning sequential composition): - Borrowed;Shared = Shared + Borrowed;Aliased = Aliased Borrowed;Unique = Unique - Shared;Shared = Shared - Shared;Unique = Error + Aliased;Aliased = Aliased + Aliased;Unique = Error - We are in a dilemma: recall that Borrowed->Shared allows code - motion, and Shared->Unique allows unique overwriting. We can't have + We are in a dilemma: recall that Borrowed->Aliased allows code + motion, and Aliased->Unique allows unique overwriting. We can't have both. We first note is that the first is a soft optimization, and the second is a hard requirement. A reasonable solution is thus to check if the m1 actually needs to use the "unique" capabilities. If not, there is no need to - relax it to Unique, and we will make it Shared, and make m0 - Shared for code-motion. However, there is no good way to do that, + relax it to Unique, and we will make it Aliased, and make m0 + Aliased for code-motion. However, there is no good way to do that, because the "unique_use" in "maybe_unique" is not complete, because the type-checking and uniqueness analysis is performed on a per-top-level-expr basis. Our solution is to record on the m0 that it is constrained by the - m1. I.e. if m1 is Unique, then m0 cannot be Shared. After the type + m1. I.e. if m1 is Unique, then m0 cannot be Aliased. After the type checking of the whole file, m1 will correctly tells whether it needs - to be Unique, and by extension whether m0 can be Shared. *) + to be Unique, and by extension whether m0 can be Aliased. *) let uniq = Maybe_unique.uniqueness l1 in - Maybe_shared.add_barrier l0 uniq; + Maybe_aliased.add_barrier l0 uniq; m1 - | Shared _, Borrowed _ -> m0 + | Aliased _, Borrowed _ -> m0 | Maybe_unique l, Borrowed occ -> - force_shared_multiuse l m1 First; - shared occ Shared.Forced - | Shared _, Maybe_shared _ -> m0 - | Maybe_unique l0, Maybe_shared l1 -> + force_aliased_multiuse l m1 First; + aliased occ Aliased.Forced + | Aliased _, Maybe_aliased _ -> m0 + | Maybe_unique l0, Maybe_aliased l1 -> (* Four cases: - Shared;Borrowed = Shared - Shared;Shared = Shared + Aliased;Borrowed = Aliased + Aliased;Aliased = Aliased Unique;Borrowed = Error - Unique;Shared = Error + Unique;Aliased = Error - As you can see, we need to force the m0 to Shared, and m1 needn't - be constrained. The result is always Shared. + As you can see, we need to force the m0 to Aliased, and m1 needn't + be constrained. The result is always Aliased. *) - let occ, _ = Maybe_shared.extract_occurrence_access l1 in - force_shared_multiuse l0 m1 First; - shared occ Shared.Forced - | Shared _, Shared _ -> m0 - | Maybe_unique l, Shared _ -> - force_shared_multiuse l m1 First; + let occ, _ = Maybe_aliased.extract_occurrence_access l1 in + force_aliased_multiuse l0 m1 First; + aliased occ Aliased.Forced + | Aliased _, Aliased _ -> m0 + | Maybe_unique l, Aliased _ -> + force_aliased_multiuse l m1 First; m1 - | Shared _, Maybe_unique l -> - force_shared_multiuse l m0 Second; + | Aliased _, Maybe_unique l -> + force_aliased_multiuse l m0 Second; m0 | Maybe_unique l0, Maybe_unique l1 -> - force_shared_multiuse l0 m1 First; - force_shared_multiuse l1 m0 Second; - shared (Maybe_unique.extract_occurrence l0) Shared.Forced + force_aliased_multiuse l0 m1 First; + force_aliased_multiuse l1 m0 Second; + aliased (Maybe_unique.extract_occurrence l0) Aliased.Forced end module Projection : sig @@ -540,10 +544,10 @@ end = struct (** Represents a tree of usage. Each node records the choose on all possible execution paths. As a result, trees such as `S -> U` is valid, even though it would be invalid if it was the result of a single path: using a parent - shared and a child uniquely is obviously bad. However, it might be the + aliased and a child uniquely is obviously bad. However, it might be the result of "choos"ing multiple path: choose `S` `N -> U`, which is valid. - INVARIANT: children >= parent. For example, having a shared child under a + INVARIANT: children >= parent. For example, having an aliased child under a unique parent is nonsense. The invariant is preserved because Usage.choose, Usage.par, and Usage.seq above are monotone, and Usage_tree.par and Usage_tree.seq, Usage_tree.choose here are node-wise. *) @@ -762,9 +766,9 @@ module Paths : sig val choose : t -> t -> t val mark_implicit_borrow_memory_address : - Maybe_shared.access -> Occurrence.t -> t -> UF.t + Maybe_aliased.access -> Occurrence.t -> t -> UF.t - val mark_shared : Occurrence.t -> Shared.reason -> t -> UF.t + val mark_aliased : Occurrence.t -> Aliased.reason -> t -> UF.t end = struct type t = UF.Path.t list @@ -781,7 +785,7 @@ end = struct let l = List.filter (function - | Atom (Monadic Uniqueness, Join_with Shared) -> true + | Atom (Monadic Uniqueness, Join_with Aliased) -> true | Atom (Comonadic Linearity, Meet_with Many) -> true | _ -> false : Modality.t -> _) @@ -810,13 +814,13 @@ end = struct still needed because they are handled differently in closures *) let barrier = ref (Uniqueness.max |> Uniqueness.disallow_left) in mark - (Maybe_shared (Maybe_shared.singleton barrier occ access)) + (Maybe_aliased (Maybe_aliased.singleton barrier occ access)) (memory_address paths) - let mark_shared occ reason paths = mark (Usage.shared occ reason) paths + let mark_aliased occ reason paths = mark (Usage.aliased occ reason) paths end -let force_shared_boundary unique_use occ ~reason = +let force_aliased_boundary unique_use occ ~reason = let maybe_unique = Maybe_unique.singleton unique_use occ in match Maybe_unique.mark_multi_use maybe_unique with | Ok () -> () @@ -849,16 +853,16 @@ module Value : sig val implicit_record_field : Modality.Value.Const.t -> string -> t -> unique_use -> t - (** Mark the value as shared_or_unique *) + (** Mark the value as aliased_or_unique *) val mark_maybe_unique : t -> UF.t (** Mark the memory_address of the value as implicitly borrowed - (borrow_or_shared). We still ask for the [occ] argument, because + (borrow_or_aliased). We still ask for the [occ] argument, because [Value.occ] is the occurrence of the value, not necessary the place where it is borrowed. *) - val mark_implicit_borrow_memory_address : Maybe_shared.access -> t -> UF.t + val mark_implicit_borrow_memory_address : Maybe_aliased.access -> t -> UF.t - val mark_shared : reason:boundary_reason -> t -> UF.t + val mark_aliased : reason:boundary_reason -> t -> UF.t end = struct type t = | Fresh @@ -893,12 +897,12 @@ end = struct | Existing { paths; unique_use; occ } -> Paths.mark (Usage.maybe_unique unique_use occ) paths - let mark_shared ~reason = function + let mark_aliased ~reason = function | Fresh -> UF.unused | Existing { paths; unique_use; occ } -> - force_shared_boundary unique_use occ ~reason; - let shared = Usage.shared occ Shared.Forced in - Paths.mark shared paths + force_aliased_boundary unique_use occ ~reason; + let aliased = Usage.aliased occ Aliased.Forced in + Paths.mark aliased paths end module Ienv : sig @@ -1082,7 +1086,7 @@ and pattern_match_single pat paths : Ienv.Extension.t * UF.t = ext, UF.par uf_read uf_pats | Tpat_lazy arg -> (* forcing a lazy expression is like calling a nullary-function *) - let uf_force = Paths.mark_shared occ Lazy paths in + let uf_force = Paths.mark_aliased occ Lazy paths in let paths = Paths.fresh () in let ext, uf_arg = pattern_match_single arg paths in ext, UF.par uf_force uf_arg @@ -1125,15 +1129,15 @@ let value_of_ident ienv unique_use occ path = (* TODO: for better error message, we should record in ienv why some variables are not in it. *) | None -> - force_shared_boundary ~reason:Out_of_mod_class unique_use occ; + force_aliased_boundary ~reason:Out_of_mod_class unique_use occ; None | Some paths -> let value = Value.existing paths unique_use occ in Some value) - (* accessing a module, which is forced by typemod to be shared and many. + (* accessing a module, which is forced by typemod to be aliased and many. Here we force it again just to be sure *) | Path.Pdot _ -> - force_shared_boundary ~reason:Paths_from_mod_class unique_use occ; + force_aliased_boundary ~reason:Paths_from_mod_class unique_use occ; None | Path.Papply _ | Path.Pextra_ty _ -> assert false @@ -1141,10 +1145,10 @@ let value_of_ident ienv unique_use occ path = The following functions are dirty hacks and used for modules and classes. Currently we treat the boundary between modules/classes and their surrounding environment coarsely. To be specific, all references in the modules/classes - pointing to the environment are treated as many and shared. This translates + pointing to the environment are treated as many and aliased. This translates to enforcement on both ends: - - inside the module, those uses needs to be forced as many and shared - - need a UF.t which marks those uses as many and shared, so that the + - inside the module, those uses needs to be forced as many and aliased + - need a UF.t which marks those uses as many and aliased, so that the parent expression can detect conflict if any. *) (** Returns all open variables inside a module. *) @@ -1167,13 +1171,13 @@ let open_variables ienv f = f iter; !ll -(** Marks all open variables in a class/module as shared, - as well as returning a UF reflecting all those shared usage. *) -let mark_shared_open_variables ienv f _loc = +(** Marks all open variables in a class/module as aliased, + as well as returning a UF reflecting all those aliased usage. *) +let mark_aliased_open_variables ienv f _loc = let ll = open_variables ienv f in let ufs = List.map - (fun value -> Value.mark_shared value ~reason:Free_var_of_mod_class) + (fun value -> Value.mark_aliased value ~reason:Free_var_of_mod_class) ll in UF.pars ufs @@ -1181,10 +1185,10 @@ let mark_shared_open_variables ienv f _loc = let lift_implicit_borrowing uf = UF.map (function - | Maybe_shared t -> + | Maybe_aliased t -> (* implicit borrowing lifted. *) - let occ, access = Maybe_shared.extract_occurrence_access t in - Usage.shared occ (Shared.Lifted access) + let occ, access = Maybe_aliased.extract_occurrence_access t in + Usage.aliased occ (Aliased.Lifted access) | m -> (* other usage stays the same *) m) @@ -1244,7 +1248,7 @@ let rec check_uniqueness_exp (ienv : Ienv.t) exp : UF.t = in let uf = UF.seq (UF.seqs uf_params) uf_body in (* we are constructing a closure here, and therefore any implicit - borrowing of free variables in the closure is in fact using shared. *) + borrowing of free variables in the closure is in fact using aliased. *) lift_implicit_borrowing uf | Texp_apply (fn, args, _, _, _) -> let uf_fn = check_uniqueness_exp ienv fn in @@ -1348,7 +1352,7 @@ let rec check_uniqueness_exp (ienv : Ienv.t) exp : UF.t = UF.pars (List.map (fun (_, _, e) -> check_uniqueness_exp ienv e) ls) | Texp_letmodule (_, _, _, mod_expr, body) -> let uf_mod = - mark_shared_open_variables ienv + mark_aliased_open_variables ienv (fun iter -> iter.module_expr iter mod_expr) mod_expr.mod_loc in @@ -1362,13 +1366,13 @@ let rec check_uniqueness_exp (ienv : Ienv.t) exp : UF.t = | Texp_object (cls_struc, _) -> (* the object (methods, values) will be type-checked by Typeclass, which invokes uniqueness check.*) - mark_shared_open_variables ienv + mark_aliased_open_variables ienv (fun iter -> iter.class_structure iter cls_struc) exp.exp_loc | Texp_pack mod_expr -> (* the module will be type-checked by Typemod which invokes uniqueness analysis. *) - mark_shared_open_variables ienv + mark_aliased_open_variables ienv (fun iter -> iter.module_expr iter mod_expr) mod_expr.mod_loc | Texp_letop { let_; ands; body } -> @@ -1385,7 +1389,7 @@ let rec check_uniqueness_exp (ienv : Ienv.t) exp : UF.t = | Texp_extension_constructor _ -> UF.unused | Texp_open (open_decl, e) -> let uf = - mark_shared_open_variables ienv + mark_aliased_open_variables ienv (fun iter -> iter.open_declaration iter open_decl) open_decl.open_loc in @@ -1531,7 +1535,7 @@ and check_uniqueness_comprehension_clause_binding ienv cbs = and check_uniqueness_binding_op ienv bo = let occ = Occurrence.mk bo.bop_loc in let uf_path = - match value_of_ident ienv shared_many_use occ bo.bop_op_path with + match value_of_ident ienv aliased_many_use occ bo.bop_op_path with | Some value -> Value.mark_maybe_unique value | None -> UF.unused in @@ -1551,14 +1555,14 @@ let report_multi_use inner first_is_of_second = let here_usage = "used" in let there_usage = match there with - | Usage.Maybe_shared t -> ( - let _, access = Maybe_shared.extract_occurrence_access t in + | Usage.Maybe_aliased t -> ( + let _, access = Maybe_aliased.extract_occurrence_access t in match access with Read -> "read from" | Write -> "written to") - | Usage.Shared t -> ( - match Shared.reason t with + | Usage.Aliased t -> ( + match Aliased.reason t with | Forced | Lazy -> "used" | Lifted access -> - Maybe_shared.string_of_access access + Maybe_aliased.string_of_access access ^ " in a closure that might be called later") | _ -> "used" in @@ -1614,7 +1618,7 @@ let report_boundary cannot_force reason = in let error = match axis with - | Uniqueness -> "This value is shared but used as unique" + | Uniqueness -> "This value is aliased but used as unique" | Linearity -> "This value is once but used as many" in Location.errorf ~loc:occ.loc "@[%s.\nHint: This value comes from %s.@]" error From 99a0b86ce97f74cc0a18fbccb502b7db5ec239be Mon Sep 17 00:00:00 2001 From: Xavier Clerc Date: Wed, 18 Sep 2024 09:37:40 +0100 Subject: [PATCH 50/76] Selection: refactor `emit_expr_aux` and `emit_tail` (#3010) --- backend/selectgen.ml | 1204 ++++++++++++++++++++++-------------------- 1 file changed, 626 insertions(+), 578 deletions(-) diff --git a/backend/selectgen.ml b/backend/selectgen.ml index 57475457554..6200794cda4 100644 --- a/backend/selectgen.ml +++ b/backend/selectgen.ml @@ -239,25 +239,26 @@ class virtual selector_generic = match exp with | Cconst_int (n, _dbg) -> let r = self#regs_for typ_int in - ret (self#insert_op env (Mach.Iconst_int (Nativeint.of_int n)) [||] r) + ret + (self#insert_op env (self#make_const_int (Nativeint.of_int n)) [||] r) | Cconst_natint (n, _dbg) -> let r = self#regs_for typ_int in - ret (self#insert_op env (Mach.Iconst_int n) [||] r) + ret (self#insert_op env (self#make_const_int n) [||] r) | Cconst_float32 (n, _dbg) -> let r = self#regs_for typ_float32 in ret (self#insert_op env - (Mach.Iconst_float32 (Int32.bits_of_float n)) + (self#make_const_float32 (Int32.bits_of_float n)) [||] r) | Cconst_float (n, _dbg) -> let r = self#regs_for typ_float in ret (self#insert_op env - (Mach.Iconst_float (Int64.bits_of_float n)) + (self#make_const_float (Int64.bits_of_float n)) [||] r) | Cconst_vec128 (bits, _dbg) -> let r = self#regs_for typ_vec128 in - ret (self#insert_op env (Mach.Iconst_vec128 bits) [||] r) + ret (self#insert_op env (self#make_const_vec128 bits) [||] r) | Cconst_symbol (n, _dbg) -> (* Cconst_symbol _ evaluates to a statically-allocated address, so its value fits in a typ_int register and is never changed by the GC. @@ -267,7 +268,7 @@ class virtual selector_generic = registered in the compilation unit's global roots structure, so adding this register to the frame table would be redundant *) let r = self#regs_for typ_int in - ret (self#insert_op env (Mach.Iconst_symbol n) [||] r) + ret (self#insert_op env (self#make_const_symbol n) [||] r) | Cvar v -> ( try ret (Select_utils.env_find v env) with Not_found -> @@ -296,15 +297,10 @@ class virtual selector_generic = (if Option.is_some provenance then let naming_op = - Mach.Iname_for_debugger - { ident = v; - provenance; - which_parameter = None; - is_assignment = true; - regs = r1 - } + self#make_name_for_debugger ~ident:v ~provenance + ~which_parameter:None ~is_assignment:true ~regs:r1 in - self#insert_debug env (Mach.Iop naming_op) Debuginfo.none [||] [||]); + self#insert_debug env naming_op Debuginfo.none [||] [||]); self#insert_moves env r1 rv; ret [||]) | Ctuple [] -> ret [||] @@ -313,21 +309,13 @@ class virtual selector_generic = | None -> None | Some (simple_list, ext_env) -> ret (self#emit_tuple ext_env simple_list)) - | Cop (Craise k, [arg], dbg) -> ( - match self#emit_expr env arg ~bound_name:None with - | None -> None - | Some r1 -> - let rd = [| Proc.loc_exn_bucket |] in - self#insert env (Mach.Iop Imove) r1 rd; - self#insert_debug env (Mach.Iraise k) dbg rd [||]; - Select_utils.set_traps_for_raise env; - None) + | Cop (Craise k, [arg], dbg) -> self#emit_expr_aux_raise env k arg dbg | Cop (Copaque, args, dbg) -> ( match self#emit_parts_list env args with | None -> None | Some (simple_args, env) -> let rs = self#emit_tuple env simple_args in - ret (self#insert_op_debug env Mach.Iopaque dbg rs rs)) + ret (self#insert_op_debug env (self#make_opaque ()) dbg rs rs)) | Cop (Ctuple_field (field, fields_layout), [arg], _dbg) -> ( match self#emit_expr env arg ~bound_name:None with | None -> None @@ -342,360 +330,402 @@ class virtual selector_generic = Array.sub loc_exp size_before (Array.length fields_layout.(field)) in ret field_slice) - | Cop (op, args, dbg) -> ( - match self#emit_parts_list env args with - | None -> None - | Some (simple_args, env) -> ( - let add_naming_op_for_bound_name regs = - match bound_name with - | None -> () - | Some bound_name -> - let provenance = VP.provenance bound_name in - if Option.is_some provenance - then - let bound_name = VP.var bound_name in - let naming_op = - Mach.Iname_for_debugger - { ident = bound_name; - provenance; - which_parameter = None; - is_assignment = false; - regs - } - in - self#insert_debug env (Mach.Iop naming_op) Debuginfo.none [||] - [||] - in - let ty = Select_utils.oper_result_type op in - let new_op, new_args = self#select_operation op simple_args dbg in - match new_op with - | Icall_ind -> - let r1 = self#emit_tuple env new_args in - let rarg = Array.sub r1 1 (Array.length r1 - 1) in - let rd = self#regs_for ty in - let loc_arg, stack_ofs_args = Proc.loc_arguments (Reg.typv rarg) in - let loc_res, stack_ofs_res = Proc.loc_results_call (Reg.typv rd) in - let stack_ofs = Stdlib.Int.max stack_ofs_args stack_ofs_res in - self#insert_move_args env rarg loc_arg stack_ofs; - self#insert_debug env (Mach.Iop new_op) dbg - (Array.append [| r1.(0) |] loc_arg) - loc_res; - (* The destination registers (as per the procedure calling - convention) need to be named right now, otherwise the result of - the function call may be unavailable in the debugger immediately - after the call. *) - add_naming_op_for_bound_name loc_res; - self#insert_move_results env loc_res rd stack_ofs; - Select_utils.set_traps_for_raise env; - Some rd - | Icall_imm _ -> - let r1 = self#emit_tuple env new_args in - let rd = self#regs_for ty in - let loc_arg, stack_ofs_args = Proc.loc_arguments (Reg.typv r1) in - let loc_res, stack_ofs_res = Proc.loc_results_call (Reg.typv rd) in - let stack_ofs = Stdlib.Int.max stack_ofs_args stack_ofs_res in - self#insert_move_args env r1 loc_arg stack_ofs; - self#insert_debug env (Mach.Iop new_op) dbg loc_arg loc_res; - add_naming_op_for_bound_name loc_res; - self#insert_move_results env loc_res rd stack_ofs; - Select_utils.set_traps_for_raise env; - Some rd - | Iextcall ({ func; ty_args; returns; _ } as r) -> - let loc_arg, stack_ofs = - self#emit_extcall_args env ty_args new_args - in - let keep_for_checking = - (not returns) - && !Select_utils.current_function_is_check_enabled - && String.equal func Cmm.caml_flambda2_invalid - in - let returns, ty = - if keep_for_checking then true, typ_int else returns, ty - in - let rd = self#regs_for ty in - let loc_res = - self#insert_op_debug env - (Mach.Iextcall { r with stack_ofs; returns }) - dbg loc_arg - (Proc.loc_external_results (Reg.typv rd)) - in - add_naming_op_for_bound_name loc_res; - self#insert_move_results env loc_res rd stack_ofs; - Select_utils.set_traps_for_raise env; - if returns then ret rd else None - | Ialloc { bytes = _; mode } -> - let rd = self#regs_for typ_val in - let bytes = Select_utils.size_expr env (Ctuple new_args) in - let alloc_words = (bytes + Arch.size_addr - 1) / Arch.size_addr in - let op = - Mach.Ialloc - { bytes = alloc_words * Arch.size_addr; - dbginfo = [{ alloc_words; alloc_dbg = dbg }]; - mode - } - in - self#insert_debug env (Mach.Iop op) dbg [||] rd; - add_naming_op_for_bound_name rd; - self#emit_stores env dbg new_args rd; - Select_utils.set_traps_for_raise env; - ret rd - | Iprobe _ -> - let r1 = self#emit_tuple env new_args in - let rd = self#regs_for ty in - let rd = self#insert_op_debug env new_op dbg r1 rd in - Select_utils.set_traps_for_raise env; - ret rd - | op -> - let r1 = self#emit_tuple env new_args in - let rd = self#regs_for ty in - add_naming_op_for_bound_name rd; - ret (self#insert_op_debug env op dbg r1 rd))) + | Cop (op, args, dbg) -> self#emit_expr_aux_op env bound_name op args dbg | Csequence (e1, e2) -> ( match self#emit_expr env e1 ~bound_name:None with | None -> None | Some _ -> self#emit_expr_aux env e2 ~bound_name) - | Cifthenelse (econd, _ifso_dbg, eif, _ifnot_dbg, eelse, dbg, _kind) -> ( - let cond, earg = self#select_condition econd in - match self#emit_expr env earg ~bound_name:None with - | None -> None - | Some rarg -> - let rif, (sif : 'self) = self#emit_sequence env eif ~bound_name in - let relse, (selse : 'self) = - self#emit_sequence env eelse ~bound_name - in - let r = Select_utils.join env rif sif relse selse ~bound_name in - self#insert_debug env - (Mach.Iifthenelse (cond, sif#extract, selse#extract)) - dbg rarg [||]; - r) - | Cswitch (esel, index, ecases, dbg, _kind) -> ( - match self#emit_expr env esel ~bound_name:None with - | None -> None - | Some rsel -> - let rscases = - Array.map - (fun (case, _dbg) -> self#emit_sequence env case ~bound_name) - ecases - in - let r = Select_utils.join_array env rscases ~bound_name in - self#insert_debug env - (Mach.Iswitch (index, Array.map (fun (_, s) -> s#extract) rscases)) - dbg rsel [||]; - r) + | Cifthenelse (econd, ifso_dbg, eif, ifnot_dbg, eelse, dbg, value_kind) -> + self#emit_expr_aux_ifthenelse env bound_name econd ifso_dbg eif + ifnot_dbg eelse dbg value_kind + | Cswitch (esel, index, ecases, dbg, value_kind) -> + self#emit_expr_aux_switch env bound_name esel index ecases dbg + value_kind | Ccatch (_, [], e1, _) -> self#emit_expr_aux env e1 ~bound_name - | Ccatch (rec_flag, handlers, body, _) -> - let handlers = - List.map - (fun (nfail, ids, e2, dbg, is_cold) -> - let rs = - List.map - (fun (id, typ) -> - let r = self#regs_for typ in - Select_utils.name_regs id r; - r) - ids - in - nfail, ids, rs, e2, dbg, is_cold) - handlers - in - let env, handlers_map = - (* Since the handlers may be recursive, and called from the body, the - same environment is used for translating both the handlers and the - body. *) - List.fold_left - (fun (env, map) (nfail, ids, rs, e2, dbg, is_cold) -> - let env, r = - Select_utils.env_add_static_exception nfail rs env () + | Ccatch (rec_flag, handlers, body, value_kind) -> + self#emit_expr_aux_catch env bound_name rec_flag handlers body + value_kind + | Cexit (lbl, args, traps) -> self#emit_expr_aux_exit env lbl args traps + | Ctrywith (e1, exn_cont, v, e2, dbg, value_kind) -> + self#emit_expr_aux_trywith env bound_name e1 exn_cont v e2 dbg + value_kind + + method private make_const_int x = Mach.Iconst_int x + + method private make_const_float32 x = Mach.Iconst_float32 x + + method private make_const_float x = Mach.Iconst_float x + + method private make_const_vec128 x = Mach.Iconst_vec128 x + + method private make_const_symbol x = Mach.Iconst_symbol x + + method private make_opaque () = Mach.Iopaque + + method private emit_expr_aux_raise env k arg dbg = + match self#emit_expr env arg ~bound_name:None with + | None -> None + | Some r1 -> + let rd = [| Proc.loc_exn_bucket |] in + self#insert env (Mach.Iop Imove) r1 rd; + self#insert_debug env (Mach.Iraise k) dbg rd [||]; + Select_utils.set_traps_for_raise env; + None + + method private emit_expr_aux_op env bound_name op args dbg = + let ret res = Some res in + match self#emit_parts_list env args with + | None -> None + | Some (simple_args, env) -> ( + let add_naming_op_for_bound_name regs = + match bound_name with + | None -> () + | Some bound_name -> + let provenance = VP.provenance bound_name in + if Option.is_some provenance + then + let bound_name = VP.var bound_name in + let naming_op = + Mach.Iname_for_debugger + { ident = bound_name; + provenance; + which_parameter = None; + is_assignment = false; + regs + } in - env, Int.Map.add nfail (r, (ids, rs, e2, dbg, is_cold)) map) - (env, Int.Map.empty) handlers + self#insert_debug env (Mach.Iop naming_op) Debuginfo.none [||] [||] in - let r_body, s_body = self#emit_sequence env body ~bound_name in - let translate_one_handler nfail - (traps_info, (ids, rs, e2, _dbg, is_cold)) = - assert (List.length ids = List.length rs); - let trap_stack = - match (!traps_info : Select_utils.trap_stack_info) with - | Unreachable -> assert false - | Reachable t -> t + let ty = Select_utils.oper_result_type op in + let new_op, new_args = self#select_operation op simple_args dbg in + match new_op with + | Icall_ind -> + let r1 = self#emit_tuple env new_args in + let rarg = Array.sub r1 1 (Array.length r1 - 1) in + let rd = self#regs_for ty in + let loc_arg, stack_ofs_args = Proc.loc_arguments (Reg.typv rarg) in + let loc_res, stack_ofs_res = Proc.loc_results_call (Reg.typv rd) in + let stack_ofs = Stdlib.Int.max stack_ofs_args stack_ofs_res in + self#insert_move_args env rarg loc_arg stack_ofs; + self#insert_debug env (Mach.Iop new_op) dbg + (Array.append [| r1.(0) |] loc_arg) + loc_res; + (* The destination registers (as per the procedure calling convention) + need to be named right now, otherwise the result of the function + call may be unavailable in the debugger immediately after the + call. *) + add_naming_op_for_bound_name loc_res; + self#insert_move_results env loc_res rd stack_ofs; + Select_utils.set_traps_for_raise env; + Some rd + | Icall_imm _ -> + let r1 = self#emit_tuple env new_args in + let rd = self#regs_for ty in + let loc_arg, stack_ofs_args = Proc.loc_arguments (Reg.typv r1) in + let loc_res, stack_ofs_res = Proc.loc_results_call (Reg.typv rd) in + let stack_ofs = Stdlib.Int.max stack_ofs_args stack_ofs_res in + self#insert_move_args env r1 loc_arg stack_ofs; + self#insert_debug env (Mach.Iop new_op) dbg loc_arg loc_res; + add_naming_op_for_bound_name loc_res; + self#insert_move_results env loc_res rd stack_ofs; + Select_utils.set_traps_for_raise env; + Some rd + | Iextcall ({ func; ty_args; returns; _ } as r) -> + let loc_arg, stack_ofs = + self#emit_extcall_args env ty_args new_args in - let ids_and_rs = List.combine ids rs in - let new_env = - List.fold_left - (fun env ((id, _typ), r) -> Select_utils.env_add id r env) - (Select_utils.env_set_trap_stack env trap_stack) - ids_and_rs + let keep_for_checking = + (not returns) + && !Select_utils.current_function_is_check_enabled + && String.equal func Cmm.caml_flambda2_invalid in - let r, s = - self#emit_sequence new_env e2 ~bound_name:None ~at_start:(fun seq -> - List.iter - (fun ((var, _typ), r) -> - let provenance = VP.provenance var in - if Option.is_some provenance - then - let var = VP.var var in - let naming_op = - Mach.Iname_for_debugger - { ident = var; - provenance; - which_parameter = None; - is_assignment = false; - regs = r - } - in - seq#insert_debug env (Mach.Iop naming_op) Debuginfo.none - [||] [||]) - ids_and_rs) + let returns, ty = + if keep_for_checking then true, typ_int else returns, ty in - (nfail, trap_stack, is_cold), (r, s) - in - let rec build_all_reachable_handlers ~already_built ~not_built = - let not_built, to_build = - Int.Map.partition - (fun _n (r, _) -> !r = Select_utils.Unreachable) - not_built + let rd = self#regs_for ty in + let loc_res = + self#insert_op_debug env + (Mach.Iextcall { r with stack_ofs; returns }) + dbg loc_arg + (Proc.loc_external_results (Reg.typv rd)) in - if Int.Map.is_empty to_build - then already_built - else - let already_built = - Int.Map.fold - (fun nfail handler already_built -> - translate_one_handler nfail handler :: already_built) - to_build already_built + add_naming_op_for_bound_name loc_res; + self#insert_move_results env loc_res rd stack_ofs; + Select_utils.set_traps_for_raise env; + if returns then ret rd else None + | Ialloc { bytes = _; mode } -> + let rd = self#regs_for typ_val in + let bytes = Select_utils.size_expr env (Ctuple new_args) in + let alloc_words = (bytes + Arch.size_addr - 1) / Arch.size_addr in + let op = + Mach.Ialloc + { bytes = alloc_words * Arch.size_addr; + dbginfo = [{ alloc_words; alloc_dbg = dbg }]; + mode + } + in + self#insert_debug env (Mach.Iop op) dbg [||] rd; + add_naming_op_for_bound_name rd; + self#emit_stores env dbg new_args rd; + Select_utils.set_traps_for_raise env; + ret rd + | Iprobe _ -> + let r1 = self#emit_tuple env new_args in + let rd = self#regs_for ty in + let rd = self#insert_op_debug env new_op dbg r1 rd in + Select_utils.set_traps_for_raise env; + ret rd + | op -> + let r1 = self#emit_tuple env new_args in + let rd = self#regs_for ty in + add_naming_op_for_bound_name rd; + ret (self#insert_op_debug env op dbg r1 rd)) + + method private emit_expr_aux_ifthenelse env bound_name econd _ifso_dbg eif + _ifnot_dbg eelse dbg _value_kind = + let cond, earg = self#select_condition econd in + match self#emit_expr env earg ~bound_name:None with + | None -> None + | Some rarg -> + let rif, (sif : 'self) = self#emit_sequence env eif ~bound_name in + let relse, (selse : 'self) = self#emit_sequence env eelse ~bound_name in + let r = Select_utils.join env rif sif relse selse ~bound_name in + self#insert_debug env + (Mach.Iifthenelse (cond, sif#extract, selse#extract)) + dbg rarg [||]; + r + + method private emit_expr_aux_switch env bound_name esel index ecases dbg + _value_kind = + match self#emit_expr env esel ~bound_name:None with + | None -> None + | Some rsel -> + let rscases = + Array.map + (fun (case, _dbg) -> self#emit_sequence env case ~bound_name) + ecases + in + let r = Select_utils.join_array env rscases ~bound_name in + self#insert_debug env + (Mach.Iswitch (index, Array.map (fun (_, s) -> s#extract) rscases)) + dbg rsel [||]; + r + + method private emit_expr_aux_catch env bound_name rec_flag handlers body + _value_kind = + let handlers = + List.map + (fun (nfail, ids, e2, dbg, is_cold) -> + let rs = + List.map + (fun (id, typ) -> + let r = self#regs_for typ in + Select_utils.name_regs id r; + r) + ids in - build_all_reachable_handlers ~already_built ~not_built + nfail, ids, rs, e2, dbg, is_cold) + handlers + in + let env, handlers_map = + (* Since the handlers may be recursive, and called from the body, the + same environment is used for translating both the handlers and the + body. *) + List.fold_left + (fun (env, map) (nfail, ids, rs, e2, dbg, is_cold) -> + let env, r = + Select_utils.env_add_static_exception nfail rs env () + in + env, Int.Map.add nfail (r, (ids, rs, e2, dbg, is_cold)) map) + (env, Int.Map.empty) handlers + in + let r_body, s_body = self#emit_sequence env body ~bound_name in + let translate_one_handler nfail (traps_info, (ids, rs, e2, _dbg, is_cold)) + = + assert (List.length ids = List.length rs); + let trap_stack = + match (!traps_info : Select_utils.trap_stack_info) with + | Unreachable -> assert false + | Reachable t -> t + in + let ids_and_rs = List.combine ids rs in + let new_env = + List.fold_left + (fun env ((id, _typ), r) -> Select_utils.env_add id r env) + (Select_utils.env_set_trap_stack env trap_stack) + ids_and_rs in - let l = - build_all_reachable_handlers ~already_built:[] ~not_built:handlers_map - (* Note: we're dropping unreachable handlers here *) + let r, s = + self#emit_sequence new_env e2 ~bound_name:None ~at_start:(fun seq -> + List.iter + (fun ((var, _typ), r) -> + let provenance = VP.provenance var in + if Option.is_some provenance + then + let var = VP.var var in + let naming_op = + Mach.Iname_for_debugger + { ident = var; + provenance; + which_parameter = None; + is_assignment = false; + regs = r + } + in + seq#insert_debug env (Mach.Iop naming_op) Debuginfo.none + [||] [||]) + ids_and_rs) in - let a = Array.of_list ((r_body, s_body) :: List.map snd l) in - let r = Select_utils.join_array env a ~bound_name in - let aux ((nfail, ts, is_cold), (_r, s)) = - nfail, ts, s#extract, is_cold + (nfail, trap_stack, is_cold), (r, s) + in + let rec build_all_reachable_handlers ~already_built ~not_built = + let not_built, to_build = + Int.Map.partition + (fun _n (r, _) -> !r = Select_utils.Unreachable) + not_built in - let final_trap_stack = - match r_body with - | Some _ -> env.trap_stack - | None -> ( - (* The body never returns, so the trap stack at the end of the catch - is the one from the handlers *) - match l with - | [] -> - (* This whole catch never returns *) - env.trap_stack - | ((_, ts, _), (_, _)) :: tl -> - assert (List.for_all (fun ((_, ts', _), (_, _)) -> ts = ts') tl); - ts) + if Int.Map.is_empty to_build + then already_built + else + let already_built = + Int.Map.fold + (fun nfail handler already_built -> + translate_one_handler nfail handler :: already_built) + to_build already_built + in + build_all_reachable_handlers ~already_built ~not_built + in + let l = + build_all_reachable_handlers ~already_built:[] ~not_built:handlers_map + (* Note: we're dropping unreachable handlers here *) + in + let a = Array.of_list ((r_body, s_body) :: List.map snd l) in + let r = Select_utils.join_array env a ~bound_name in + let aux ((nfail, ts, is_cold), (_r, s)) = nfail, ts, s#extract, is_cold in + let final_trap_stack = + match r_body with + | Some _ -> env.Select_utils.trap_stack + | None -> ( + (* The body never returns, so the trap stack at the end of the catch + is the one from the handlers *) + match l with + | [] -> + (* This whole catch never returns *) + env.Select_utils.trap_stack + | ((_, ts, _), (_, _)) :: tl -> + assert (List.for_all (fun ((_, ts', _), (_, _)) -> ts = ts') tl); + ts) + in + self#insert env + (Mach.Icatch (rec_flag, final_trap_stack, List.map aux l, s_body#extract)) + [||] [||]; + r + + method private emit_expr_aux_exit env lbl args traps = + match self#emit_parts_list env args with + | None -> None + | Some (simple_list, ext_env) -> ( + match lbl with + | Lbl nfail -> + let src = self#emit_tuple ext_env simple_list in + let handler = + try Select_utils.env_find_static_exception nfail env + with Not_found -> + Misc.fatal_error + ("Selection.emit_expr: unbound label " + ^ Stdlib.Int.to_string nfail) + in + (* Intermediate registers to handle cases where some registers from + src are present in dest *) + let tmp_regs = Reg.createv_like src in + (* Ccatch registers must not contain out of heap pointers *) + Array.iter (fun reg -> assert (reg.Reg.typ <> Addr)) src; + self#insert_moves env src tmp_regs; + self#insert_moves env tmp_regs (Array.concat handler.regs); + self#insert env (Mach.Iexit (nfail, traps)) [||] [||]; + Select_utils.set_traps nfail handler.Select_utils.traps_ref + env.Select_utils.trap_stack traps; + None + | Return_lbl -> ( + match simple_list with + | [expr] -> + self#emit_return ext_env expr traps; + None + | [] -> + Misc.fatal_error "Selection.emit_expr: Return without arguments" + | _ :: _ :: _ -> + Misc.fatal_error + "Selection.emit_expr: Return with too many arguments")) + + method private emit_expr_aux_trywith env bound_name e1 exn_cont v e2 dbg + _value_kind = + let env_body = Select_utils.env_enter_trywith env exn_cont () in + let r1, s1 = self#emit_sequence env_body e1 ~bound_name in + let rv = self#regs_for typ_val in + let with_handler env_handler e2 = + let r2, s2 = + self#emit_sequence env_handler e2 ~bound_name ~at_start:(fun seq -> + let provenance = VP.provenance v in + if Option.is_some provenance + then + let var = VP.var v in + let naming_op = + Mach.Iname_for_debugger + { ident = var; + provenance; + which_parameter = None; + is_assignment = false; + regs = rv + } + in + seq#insert_debug env (Mach.Iop naming_op) Debuginfo.none [||] + [||]) in + let r = Select_utils.join env r1 s1 r2 s2 ~bound_name in self#insert env - (Mach.Icatch - (rec_flag, final_trap_stack, List.map aux l, s_body#extract)) + (Mach.Itrywith + ( s1#extract, + exn_cont, + ( env_handler.Select_utils.trap_stack, + Mach.instr_cons_debug (Mach.Iop Imove) + [| Proc.loc_exn_bucket |] rv dbg s2#extract ) )) [||] [||]; r - | Cexit (lbl, args, traps) -> ( - match self#emit_parts_list env args with - | None -> None - | Some (simple_list, ext_env) -> ( - match lbl with - | Lbl nfail -> - let src = self#emit_tuple ext_env simple_list in - let handler = - try Select_utils.env_find_static_exception nfail env - with Not_found -> - Misc.fatal_error - ("Selection.emit_expr: unbound label " - ^ Stdlib.Int.to_string nfail) - in - (* Intermediate registers to handle cases where some registers from - src are present in dest *) - let tmp_regs = Reg.createv_like src in - (* Ccatch registers must not contain out of heap pointers *) - Array.iter (fun reg -> assert (reg.Reg.typ <> Addr)) src; - self#insert_moves env src tmp_regs; - self#insert_moves env tmp_regs (Array.concat handler.regs); - self#insert env (Mach.Iexit (nfail, traps)) [||] [||]; - Select_utils.set_traps nfail handler.traps_ref env.trap_stack traps; - None - | Return_lbl -> ( - match simple_list with - | [expr] -> - self#emit_return ext_env expr traps; - None - | [] -> - Misc.fatal_error "Selection.emit_expr: Return without arguments" - | _ :: _ :: _ -> - Misc.fatal_error - "Selection.emit_expr: Return with too many arguments"))) - | Ctrywith (e1, exn_cont, v, e2, dbg, _value_kind) -> ( - let env_body = Select_utils.env_enter_trywith env exn_cont () in - let r1, s1 = self#emit_sequence env_body e1 ~bound_name in - let rv = self#regs_for typ_val in - let with_handler env_handler e2 = - let r2, s2 = - self#emit_sequence env_handler e2 ~bound_name ~at_start:(fun seq -> - let provenance = VP.provenance v in - if Option.is_some provenance - then - let var = VP.var v in - let naming_op = - Mach.Iname_for_debugger - { ident = var; - provenance; - which_parameter = None; - is_assignment = false; - regs = rv - } - in - seq#insert_debug env (Mach.Iop naming_op) Debuginfo.none [||] - [||]) - in - let r = Select_utils.join env r1 s1 r2 s2 ~bound_name in - self#insert env - (Mach.Itrywith - ( s1#extract, - exn_cont, - ( env_handler.Select_utils.trap_stack, - Mach.instr_cons_debug (Mach.Iop Imove) - [| Proc.loc_exn_bucket |] rv dbg s2#extract ) )) - [||] [||]; - r + in + let env = Select_utils.env_add v rv env in + match Select_utils.env_find_static_exception exn_cont env_body with + | { traps_ref = { contents = Reachable ts }; _ } -> + with_handler (Select_utils.env_set_trap_stack env ts) e2 + | { traps_ref = { contents = Unreachable }; _ } -> + let dummy_constant = Cconst_int (1, Debuginfo.none) in + let segfault = + Cmm.( + Cop + ( Cload + { memory_chunk = Word_int; + mutability = Mutable; + is_atomic = false + }, + [Cconst_int (0, Debuginfo.none)], + Debuginfo.none )) in - let env = Select_utils.env_add v rv env in - match Select_utils.env_find_static_exception exn_cont env_body with - | { traps_ref = { contents = Reachable ts }; _ } -> - with_handler (Select_utils.env_set_trap_stack env ts) e2 - | { traps_ref = { contents = Unreachable }; _ } -> - let dummy_constant = Cconst_int (1, Debuginfo.none) in - let segfault = - Cmm.( - Cop - ( Cload - { memory_chunk = Word_int; - mutability = Mutable; - is_atomic = false - }, - [Cconst_int (0, Debuginfo.none)], - Debuginfo.none )) - in - let dummy_raise = - Cop (Craise Raise_notrace, [dummy_constant], Debuginfo.none) - in - let unreachable = - (* The use of a raise operation means that this handler is known not - to return, making it compatible with any layout for the body or - surrounding code. We also set the trap stack to [Uncaught] to - ensure that we don't introduce spurious control-flow edges inside - the function. *) - Csequence (segfault, dummy_raise) - in - let env = Select_utils.env_set_trap_stack env Uncaught in - with_handler env unreachable - (* Misc.fatal_errorf "Selection.emit_expr: \ * Unreachable exception - handler %d" lbl *) - | exception Not_found -> - Misc.fatal_errorf "Selection.emit_expr: Unbound handler %d" exn_cont) + let dummy_raise = + Cop (Craise Raise_notrace, [dummy_constant], Debuginfo.none) + in + let unreachable = + (* The use of a raise operation means that this handler is known not + to return, making it compatible with any layout for the body or + surrounding code. We also set the trap stack to [Uncaught] to + ensure that we don't introduce spurious control-flow edges inside + the function. *) + Csequence (segfault, dummy_raise) + in + let env = Select_utils.env_set_trap_stack env Uncaught in + with_handler env unreachable + (* Misc.fatal_errorf "Selection.emit_expr: \ * Unreachable exception + handler %d" lbl *) + | exception Not_found -> + Misc.fatal_errorf "Selection.emit_expr: Unbound handler %d" exn_cont method private emit_sequence ?at_start (env : environment) exp ~bound_name : _ * 'self = @@ -731,240 +761,258 @@ class virtual selector_generic = | None -> () | Some r1 -> self#emit_tail (self#bind_let_mut env v k r1) e2) | Cphantom_let (_var, _defining_expr, body) -> self#emit_tail env body - | Cop ((Capply (ty, Rc_normal) as op), args, dbg) -> ( - match self#emit_parts_list env args with - | None -> () - | Some (simple_args, env) -> ( - let new_op, new_args = self#select_operation op simple_args dbg in - match new_op with - | Icall_ind -> - let r1 = self#emit_tuple env new_args in - let rd = self#regs_for ty in - let rarg = Array.sub r1 1 (Array.length r1 - 1) in - let loc_arg, stack_ofs_args = Proc.loc_arguments (Reg.typv rarg) in - let loc_res, stack_ofs_res = Proc.loc_results_call (Reg.typv rd) in - let stack_ofs = Stdlib.Int.max stack_ofs_args stack_ofs_res in - if stack_ofs = 0 && Select_utils.trap_stack_is_empty env - then ( - let call = Mach.Iop Itailcall_ind in - self#insert_moves env rarg loc_arg; - self#insert_debug env call dbg - (Array.append [| r1.(0) |] loc_arg) - [||]) - else ( - self#insert_move_args env rarg loc_arg stack_ofs; - self#insert_debug env (Mach.Iop new_op) dbg - (Array.append [| r1.(0) |] loc_arg) - loc_res; - Select_utils.set_traps_for_raise env; - self#insert env (Mach.Iop (Istackoffset (-stack_ofs))) [||] [||]; - self#insert env - (Mach.Ireturn (Select_utils.pop_all_traps env)) - loc_res [||]) - | Icall_imm { func } -> - let r1 = self#emit_tuple env new_args in - let rd = self#regs_for ty in - let loc_arg, stack_ofs_args = Proc.loc_arguments (Reg.typv r1) in - let loc_res, stack_ofs_res = Proc.loc_results_call (Reg.typv rd) in - let stack_ofs = Stdlib.Int.max stack_ofs_args stack_ofs_res in - if stack_ofs = 0 && Select_utils.trap_stack_is_empty env - then ( - let call = Mach.Iop (Itailcall_imm { func }) in - self#insert_moves env r1 loc_arg; - self#insert_debug env call dbg loc_arg [||]) - else if func.sym_name = !Select_utils.current_function_name - && Select_utils.trap_stack_is_empty env - then ( - let call = Mach.Iop (Itailcall_imm { func }) in - let loc_arg' = Proc.loc_parameters (Reg.typv r1) in - self#insert_moves env r1 loc_arg'; - self#insert_debug env call dbg loc_arg' [||]) - else ( - self#insert_move_args env r1 loc_arg stack_ofs; - self#insert_debug env (Mach.Iop new_op) dbg loc_arg loc_res; - Select_utils.set_traps_for_raise env; - self#insert env (Mach.Iop (Istackoffset (-stack_ofs))) [||] [||]; - self#insert env - (Mach.Ireturn (Select_utils.pop_all_traps env)) - loc_res [||]) - | _ -> Misc.fatal_error "Selection.emit_tail")) + | Cop ((Capply (ty, Rc_normal) as op), args, dbg) -> + self#emit_tail_apply env ty op args dbg | Csequence (e1, e2) -> ( match self#emit_expr env e1 ~bound_name:None with | None -> () | Some _ -> self#emit_tail env e2) - | Cifthenelse (econd, _ifso_dbg, eif, _ifnot_dbg, eelse, dbg, _kind) -> ( - let cond, earg = self#select_condition econd in - match self#emit_expr env earg ~bound_name:None with - | None -> () - | Some rarg -> - self#insert_debug env - (Mach.Iifthenelse - ( cond, - self#emit_tail_sequence env eif, - self#emit_tail_sequence env eelse )) - dbg rarg [||]) - | Cswitch (esel, index, ecases, dbg, _kind) -> ( - match self#emit_expr env esel ~bound_name:None with - | None -> () - | Some rsel -> - let cases = - Array.map - (fun (case, _dbg) -> self#emit_tail_sequence env case) - ecases - in - self#insert_debug env (Mach.Iswitch (index, cases)) dbg rsel [||]) + | Cifthenelse (econd, ifso_dbg, eif, ifnot_dbg, eelse, dbg, value_kind) -> + self#emit_tail_ifthenelse env econd ifso_dbg eif ifnot_dbg eelse dbg + value_kind + | Cswitch (esel, index, ecases, dbg, value_kind) -> + self#emit_tail_switch env esel index ecases dbg value_kind | Ccatch (_, [], e1, _) -> self#emit_tail env e1 - | Ccatch (rec_flag, handlers, e1, _) -> - let handlers = - List.map - (fun (nfail, ids, e2, dbg, is_cold) -> - let rs = - List.map - (fun (id, typ) -> - let r = self#regs_for typ in - Select_utils.name_regs id r; - r) - ids - in - nfail, ids, rs, e2, dbg, is_cold) - handlers + | Ccatch (rec_flag, handlers, e1, value_kind) -> + self#emit_tail_catch env rec_flag handlers e1 value_kind + | Ctrywith (e1, exn_cont, v, e2, dbg, value_kind) -> + self#emit_tail_trywith env e1 exn_cont v e2 dbg value_kind + | Cop _ | Cconst_int _ | Cconst_natint _ | Cconst_float32 _ + | Cconst_float _ | Cconst_symbol _ | Cconst_vec128 _ | Cvar _ | Cassign _ + | Ctuple _ | Cexit _ -> + self#emit_return env exp (Select_utils.pop_all_traps env) + + method private emit_tail_apply env ty op args dbg = + match self#emit_parts_list env args with + | None -> () + | Some (simple_args, env) -> ( + let new_op, new_args = self#select_operation op simple_args dbg in + match new_op with + | Icall_ind -> + let r1 = self#emit_tuple env new_args in + let rd = self#regs_for ty in + let rarg = Array.sub r1 1 (Array.length r1 - 1) in + let loc_arg, stack_ofs_args = Proc.loc_arguments (Reg.typv rarg) in + let loc_res, stack_ofs_res = Proc.loc_results_call (Reg.typv rd) in + let stack_ofs = Stdlib.Int.max stack_ofs_args stack_ofs_res in + if stack_ofs = 0 && Select_utils.trap_stack_is_empty env + then ( + let call = Mach.Iop Itailcall_ind in + self#insert_moves env rarg loc_arg; + self#insert_debug env call dbg + (Array.append [| r1.(0) |] loc_arg) + [||]) + else ( + self#insert_move_args env rarg loc_arg stack_ofs; + self#insert_debug env (Mach.Iop new_op) dbg + (Array.append [| r1.(0) |] loc_arg) + loc_res; + Select_utils.set_traps_for_raise env; + self#insert env (Mach.Iop (Istackoffset (-stack_ofs))) [||] [||]; + self#insert env + (Mach.Ireturn (Select_utils.pop_all_traps env)) + loc_res [||]) + | Icall_imm { func } -> + let r1 = self#emit_tuple env new_args in + let rd = self#regs_for ty in + let loc_arg, stack_ofs_args = Proc.loc_arguments (Reg.typv r1) in + let loc_res, stack_ofs_res = Proc.loc_results_call (Reg.typv rd) in + let stack_ofs = Stdlib.Int.max stack_ofs_args stack_ofs_res in + if stack_ofs = 0 && Select_utils.trap_stack_is_empty env + then ( + let call = Mach.Iop (Itailcall_imm { func }) in + self#insert_moves env r1 loc_arg; + self#insert_debug env call dbg loc_arg [||]) + else if func.sym_name = !Select_utils.current_function_name + && Select_utils.trap_stack_is_empty env + then ( + let call = Mach.Iop (Itailcall_imm { func }) in + let loc_arg' = Proc.loc_parameters (Reg.typv r1) in + self#insert_moves env r1 loc_arg'; + self#insert_debug env call dbg loc_arg' [||]) + else ( + self#insert_move_args env r1 loc_arg stack_ofs; + self#insert_debug env (Mach.Iop new_op) dbg loc_arg loc_res; + Select_utils.set_traps_for_raise env; + self#insert env (Mach.Iop (Istackoffset (-stack_ofs))) [||] [||]; + self#insert env + (Mach.Ireturn (Select_utils.pop_all_traps env)) + loc_res [||]) + | _ -> Misc.fatal_error "Selection.emit_tail") + + method private emit_tail_ifthenelse env econd _ifso_dbg eif _ifnot_dbg eelse + dbg _value_kind = + let cond, earg = self#select_condition econd in + match self#emit_expr env earg ~bound_name:None with + | None -> () + | Some rarg -> + self#insert_debug env + (Mach.Iifthenelse + ( cond, + self#emit_tail_sequence env eif, + self#emit_tail_sequence env eelse )) + dbg rarg [||] + + method private emit_tail_switch env esel index ecases dbg _value_kind = + match self#emit_expr env esel ~bound_name:None with + | None -> () + | Some rsel -> + let cases = + Array.map + (fun (case, _dbg) -> self#emit_tail_sequence env case) + ecases + in + self#insert_debug env (Mach.Iswitch (index, cases)) dbg rsel [||] + + method private emit_tail_catch env rec_flag handlers e1 _value_kind = + let handlers = + List.map + (fun (nfail, ids, e2, dbg, is_cold) -> + let rs = + List.map + (fun (id, typ) -> + let r = self#regs_for typ in + Select_utils.name_regs id r; + r) + ids + in + nfail, ids, rs, e2, dbg, is_cold) + handlers + in + let env, handlers_map = + List.fold_left + (fun (env, map) (nfail, ids, rs, e2, dbg, is_cold) -> + let env, r = + Select_utils.env_add_static_exception nfail rs env () + in + env, Int.Map.add nfail (r, (ids, rs, e2, dbg, is_cold)) map) + (env, Int.Map.empty) handlers + in + let s_body = self#emit_tail_sequence env e1 in + let translate_one_handler nfail (trap_info, (ids, rs, e2, _dbg, is_cold)) + = + assert (List.length ids = List.length rs); + let trap_stack = + match (!trap_info : Select_utils.trap_stack_info) with + | Unreachable -> assert false + | Reachable t -> t in - let env, handlers_map = + let ids_and_rs = List.combine ids rs in + let new_env = List.fold_left - (fun (env, map) (nfail, ids, rs, e2, dbg, is_cold) -> - let env, r = - Select_utils.env_add_static_exception nfail rs env () - in - env, Int.Map.add nfail (r, (ids, rs, e2, dbg, is_cold)) map) - (env, Int.Map.empty) handlers + (fun env ((id, _typ), r) -> Select_utils.env_add id r env) + (Select_utils.env_set_trap_stack env trap_stack) + ids_and_rs in - let s_body = self#emit_tail_sequence env e1 in - let translate_one_handler nfail (trap_info, (ids, rs, e2, _dbg, is_cold)) - = - assert (List.length ids = List.length rs); - let trap_stack = - match (!trap_info : Select_utils.trap_stack_info) with - | Unreachable -> assert false - | Reachable t -> t - in - let ids_and_rs = List.combine ids rs in - let new_env = - List.fold_left - (fun env ((id, _typ), r) -> Select_utils.env_add id r env) - (Select_utils.env_set_trap_stack env trap_stack) - ids_and_rs - in - let seq = - self#emit_tail_sequence new_env e2 ~at_start:(fun seq -> - List.iter - (fun ((var, _typ), r) -> - let provenance = VP.provenance var in - if Option.is_some provenance - then - let var = VP.var var in - let naming_op = - Mach.Iname_for_debugger - { ident = var; - provenance; - which_parameter = None; - is_assignment = false; - regs = r - } - in - seq#insert_debug new_env (Mach.Iop naming_op) - Debuginfo.none [||] [||]) - ids_and_rs) - in - nfail, trap_stack, seq, is_cold + let seq = + self#emit_tail_sequence new_env e2 ~at_start:(fun seq -> + List.iter + (fun ((var, _typ), r) -> + let provenance = VP.provenance var in + if Option.is_some provenance + then + let var = VP.var var in + let naming_op = + Mach.Iname_for_debugger + { ident = var; + provenance; + which_parameter = None; + is_assignment = false; + regs = r + } + in + seq#insert_debug new_env (Mach.Iop naming_op) Debuginfo.none + [||] [||]) + ids_and_rs) in - let rec build_all_reachable_handlers ~already_built ~not_built = - let not_built, to_build = - Int.Map.partition - (fun _n (r, _) -> !r = Select_utils.Unreachable) - not_built - in - if Int.Map.is_empty to_build - then already_built - else - let already_built = - Int.Map.fold - (fun nfail handler already_built -> - translate_one_handler nfail handler :: already_built) - to_build already_built - in - build_all_reachable_handlers ~already_built ~not_built + nfail, trap_stack, seq, is_cold + in + let rec build_all_reachable_handlers ~already_built ~not_built = + let not_built, to_build = + Int.Map.partition + (fun _n (r, _) -> !r = Select_utils.Unreachable) + not_built in - let new_handlers = - build_all_reachable_handlers ~already_built:[] ~not_built:handlers_map - (* Note: we're dropping unreachable handlers here *) + if Int.Map.is_empty to_build + then already_built + else + let already_built = + Int.Map.fold + (fun nfail handler already_built -> + translate_one_handler nfail handler :: already_built) + to_build already_built + in + build_all_reachable_handlers ~already_built ~not_built + in + let new_handlers = + build_all_reachable_handlers ~already_built:[] ~not_built:handlers_map + (* Note: we're dropping unreachable handlers here *) + in + (* The final trap stack doesn't matter, as it's not reachable. *) + self#insert env + (Mach.Icatch + (rec_flag, env.Select_utils.trap_stack, new_handlers, s_body)) + [||] [||] + + method private emit_tail_trywith env e1 exn_cont v e2 dbg _value_kind = + let env_body = Select_utils.env_enter_trywith env exn_cont () in + let s1 = self#emit_tail_sequence env_body e1 in + let rv = self#regs_for typ_val in + let with_handler env_handler e2 = + let s2 = + self#emit_tail_sequence env_handler e2 ~at_start:(fun seq -> + let provenance = VP.provenance v in + if Option.is_some provenance + then + let var = VP.var v in + let naming_op = + Mach.Iname_for_debugger + { ident = var; + provenance; + which_parameter = None; + is_assignment = false; + regs = rv + } + in + seq#insert_debug env_handler (Mach.Iop naming_op) Debuginfo.none + [||] [||]) in - (* The final trap stack doesn't matter, as it's not reachable. *) self#insert env - (Mach.Icatch (rec_flag, env.trap_stack, new_handlers, s_body)) + (Mach.Itrywith + ( s1, + exn_cont, + ( env_handler.Select_utils.trap_stack, + Mach.instr_cons_debug (Iop Imove) [| Proc.loc_exn_bucket |] rv + dbg s2 ) )) [||] [||] - | Ctrywith (e1, exn_cont, v, e2, dbg, _value_kind) -> ( - let env_body = Select_utils.env_enter_trywith env exn_cont () in - let s1 = self#emit_tail_sequence env_body e1 in - let rv = self#regs_for typ_val in - let with_handler env_handler e2 = - let s2 = - self#emit_tail_sequence env_handler e2 ~at_start:(fun seq -> - let provenance = VP.provenance v in - if Option.is_some provenance - then - let var = VP.var v in - let naming_op = - Mach.Iname_for_debugger - { ident = var; - provenance; - which_parameter = None; - is_assignment = false; - regs = rv - } - in - seq#insert_debug env_handler (Mach.Iop naming_op) - Debuginfo.none [||] [||]) - in - self#insert env - (Mach.Itrywith - ( s1, - exn_cont, - ( env_handler.Select_utils.trap_stack, - Mach.instr_cons_debug (Iop Imove) [| Proc.loc_exn_bucket |] - rv dbg s2 ) )) - [||] [||] + in + let env = Select_utils.env_add v rv env in + match Select_utils.env_find_static_exception exn_cont env_body with + | { traps_ref = { contents = Reachable ts }; _ } -> + with_handler (Select_utils.env_set_trap_stack env ts) e2 + | { traps_ref = { contents = Unreachable }; _ } -> + (* Note: The following [unreachable] expression has machtype [|Int|], + but this might not be the correct machtype for this function's return + value. It doesn't matter at runtime since the expression cannot + return, but if we start checking (or joining) the machtypes of the + different tails we will need to implement something like the + [emit_expr_aux] version above, that hides the machtype. *) + let unreachable = + Cmm.( + Cop + ( Cload + { memory_chunk = Word_int; + mutability = Mutable; + is_atomic = false + }, + [Cconst_int (0, Debuginfo.none)], + Debuginfo.none )) in - let env = Select_utils.env_add v rv env in - match Select_utils.env_find_static_exception exn_cont env_body with - | { traps_ref = { contents = Reachable ts }; _ } -> - with_handler (Select_utils.env_set_trap_stack env ts) e2 - | { traps_ref = { contents = Unreachable }; _ } -> - (* Note: The following [unreachable] expression has machtype [|Int|], - but this might not be the correct machtype for this function's - return value. It doesn't matter at runtime since the expression - cannot return, but if we start checking (or joining) the machtypes - of the different tails we will need to implement something like the - [emit_expr_aux] version above, that hides the machtype. *) - let unreachable = - Cmm.( - Cop - ( Cload - { memory_chunk = Word_int; - mutability = Mutable; - is_atomic = false - }, - [Cconst_int (0, Debuginfo.none)], - Debuginfo.none )) - in - with_handler env unreachable - (* Misc.fatal_errorf "Selection.emit_expr: \ Unreachable exception - handler %d" lbl *) - | exception Not_found -> - Misc.fatal_errorf "Selection.emit_expr: Unbound handler %d" exn_cont) - | Cop _ | Cconst_int _ | Cconst_natint _ | Cconst_float32 _ - | Cconst_float _ | Cconst_symbol _ | Cconst_vec128 _ | Cvar _ | Cassign _ - | Ctuple _ | Cexit _ -> - self#emit_return env exp (Select_utils.pop_all_traps env) + with_handler env unreachable + (* Misc.fatal_errorf "Selection.emit_expr: \ Unreachable exception handler + %d" lbl *) + | exception Not_found -> + Misc.fatal_errorf "Selection.emit_expr: Unbound handler %d" exn_cont method private emit_tail_sequence ?at_start env exp = let s = {} in From b0f065383aa897e3be673bbfd4c6059aaac8d4ff Mon Sep 17 00:00:00 2001 From: Xavier Clerc Date: Wed, 18 Sep 2024 10:17:38 +0100 Subject: [PATCH 51/76] Selection: move the common parts of `emit_expr_aux` and `emit_tail` to the utility module (#3012) --- backend/select_utils.ml | 303 +++++++++++++++++++++++++++++++++++++++ backend/select_utils.mli | 151 ++++++++++++++++++- backend/selectgen.ml | 193 ++----------------------- backend/selectgen.mli | 135 +++++++++++++++++ 4 files changed, 600 insertions(+), 182 deletions(-) diff --git a/backend/select_utils.ml b/backend/select_utils.ml index 8f29af49ea5..7a9dfd5a6d4 100644 --- a/backend/select_utils.ml +++ b/backend/select_utils.ml @@ -474,6 +474,18 @@ class virtual ['env, 'op, 'instr] common_selector = regs:Reg.t array -> 'instr + method virtual make_const_int : nativeint -> 'op + + method virtual make_const_float32 : int32 -> 'op + + method virtual make_const_float : int64 -> 'op + + method virtual make_const_vec128 : vec128_bits -> 'op + + method virtual make_const_symbol : symbol -> 'op + + method virtual make_opaque : unit -> 'op + (* A syntactic criterion used in addition to judgements about (co)effects as to whether the evaluation of a given expression may be deferred by [emit_parts]. This criterion is a property of the instruction selection @@ -865,4 +877,295 @@ class virtual ['env, 'op, 'instr] common_selector = [||]; a := Arch.offset_addressing !a (size_expr env e))) data + + (* Emit an expression. + + [bound_name] is the name that will be bound to the result of evaluating + the expression, if such exists. This is used for emitting debugging info. + + Returns: - [None] if the expression does not finish normally (e.g. + raises) - [Some rs] if the expression yields a result in registers + [rs] *) + method emit_expr (env : 'env environment) exp ~bound_name = + self#emit_expr_aux env exp ~bound_name + + (* Emit an expression which may end some regions early. + + Returns: - [None] if the expression does not finish normally (e.g. + raises) - [Some (rs, unclosed)] if the expression yields a result in + [rs], having left [unclosed] (a suffix of env.regions) regions open *) + method emit_expr_aux (env : 'env environment) exp ~bound_name + : Reg.t array option = + (* Normal case of returning a value: no regions are closed *) + let ret res = Some res in + match exp with + | Cconst_int (n, _dbg) -> + let r = self#regs_for typ_int in + ret + (self#insert_op env (self#make_const_int (Nativeint.of_int n)) [||] r) + | Cconst_natint (n, _dbg) -> + let r = self#regs_for typ_int in + ret (self#insert_op env (self#make_const_int n) [||] r) + | Cconst_float32 (n, _dbg) -> + let r = self#regs_for typ_float32 in + ret + (self#insert_op env + (self#make_const_float32 (Int32.bits_of_float n)) + [||] r) + | Cconst_float (n, _dbg) -> + let r = self#regs_for typ_float in + ret + (self#insert_op env + (self#make_const_float (Int64.bits_of_float n)) + [||] r) + | Cconst_vec128 (bits, _dbg) -> + let r = self#regs_for typ_vec128 in + ret (self#insert_op env (self#make_const_vec128 bits) [||] r) + | Cconst_symbol (n, _dbg) -> + (* Cconst_symbol _ evaluates to a statically-allocated address, so its + value fits in a typ_int register and is never changed by the GC. + + Some Cconst_symbols point to statically-allocated blocks, some of + which may point to heap values. However, any such blocks will be + registered in the compilation unit's global roots structure, so + adding this register to the frame table would be redundant *) + let r = self#regs_for typ_int in + ret (self#insert_op env (self#make_const_symbol n) [||] r) + | Cvar v -> ( + try ret (env_find v env) + with Not_found -> + Misc.fatal_error + ("Selection.emit_expr: unbound var " ^ V.unique_name v)) + | Clet (v, e1, e2) -> ( + match self#emit_expr env e1 ~bound_name:(Some v) with + | None -> None + | Some r1 -> self#emit_expr_aux (self#bind_let env v r1) e2 ~bound_name) + | Clet_mut (v, k, e1, e2) -> ( + match self#emit_expr env e1 ~bound_name:(Some v) with + | None -> None + | Some r1 -> + self#emit_expr_aux (self#bind_let_mut env v k r1) e2 ~bound_name) + | Cphantom_let (_var, _defining_expr, body) -> + self#emit_expr_aux env body ~bound_name + | Cassign (v, e1) -> ( + let rv, provenance = + try env_find_mut v env + with Not_found -> + Misc.fatal_error ("Selection.emit_expr: unbound var " ^ V.name v) + in + match self#emit_expr env e1 ~bound_name:None with + | None -> None + | Some r1 -> + (if Option.is_some provenance + then + let naming_op = + self#make_name_for_debugger ~ident:v ~provenance + ~which_parameter:None ~is_assignment:true ~regs:r1 + in + self#insert_debug env naming_op Debuginfo.none [||] [||]); + self#insert_moves env r1 rv; + ret [||]) + | Ctuple [] -> ret [||] + | Ctuple exp_list -> ( + match self#emit_parts_list env exp_list with + | None -> None + | Some (simple_list, ext_env) -> + ret (self#emit_tuple ext_env simple_list)) + | Cop (Craise k, [arg], dbg) -> self#emit_expr_aux_raise env k arg dbg + | Cop (Copaque, args, dbg) -> ( + match self#emit_parts_list env args with + | None -> None + | Some (simple_args, env) -> + let rs = self#emit_tuple env simple_args in + ret (self#insert_op_debug env (self#make_opaque ()) dbg rs rs)) + | Cop (Ctuple_field (field, fields_layout), [arg], _dbg) -> ( + match self#emit_expr env arg ~bound_name:None with + | None -> None + | Some loc_exp -> + let flat_size a = + Array.fold_left (fun acc t -> acc + Array.length t) 0 a + in + assert (Array.length loc_exp = flat_size fields_layout); + let before = Array.sub fields_layout 0 field in + let size_before = flat_size before in + let field_slice = + Array.sub loc_exp size_before (Array.length fields_layout.(field)) + in + ret field_slice) + | Cop (op, args, dbg) -> self#emit_expr_aux_op env bound_name op args dbg + | Csequence (e1, e2) -> ( + match self#emit_expr env e1 ~bound_name:None with + | None -> None + | Some _ -> self#emit_expr_aux env e2 ~bound_name) + | Cifthenelse (econd, ifso_dbg, eif, ifnot_dbg, eelse, dbg, value_kind) -> + self#emit_expr_aux_ifthenelse env bound_name econd ifso_dbg eif + ifnot_dbg eelse dbg value_kind + | Cswitch (esel, index, ecases, dbg, value_kind) -> + self#emit_expr_aux_switch env bound_name esel index ecases dbg + value_kind + | Ccatch (_, [], e1, _) -> self#emit_expr_aux env e1 ~bound_name + | Ccatch (rec_flag, handlers, body, value_kind) -> + self#emit_expr_aux_catch env bound_name rec_flag handlers body + value_kind + | Cexit (lbl, args, traps) -> self#emit_expr_aux_exit env lbl args traps + | Ctrywith (e1, exn_cont, v, e2, dbg, value_kind) -> + self#emit_expr_aux_trywith env bound_name e1 exn_cont v e2 dbg + value_kind + + method virtual emit_expr_aux_raise + : 'env environment -> + Lambda.raise_kind -> + expression -> + Debuginfo.t -> + Reg.t array option + + method virtual emit_expr_aux_op + : 'env environment -> + VP.t option -> + operation -> + expression list -> + Debuginfo.t -> + Reg.t array option + + method virtual emit_expr_aux_ifthenelse + : 'env environment -> + VP.t option -> + expression -> + Debuginfo.t -> + expression -> + Debuginfo.t -> + expression -> + Debuginfo.t -> + kind_for_unboxing -> + Reg.t array option + + method virtual emit_expr_aux_switch + : 'env environment -> + VP.t option -> + expression -> + int array -> + (expression * Debuginfo.t) array -> + Debuginfo.t -> + kind_for_unboxing -> + Reg.t array option + + method virtual emit_expr_aux_catch + : 'env environment -> + VP.t option -> + rec_flag -> + (Lambda.static_label + * (VP.t * machtype) list + * expression + * Debuginfo.t + * bool) + list -> + expression -> + kind_for_unboxing -> + Reg.t array option + + method virtual emit_expr_aux_exit + : 'env environment -> + exit_label -> + expression list -> + trap_action list -> + Reg.t array option + + method virtual emit_expr_aux_trywith + : 'env environment -> + VP.t option -> + expression -> + trywith_shared_label -> + VP.t -> + expression -> + Debuginfo.t -> + kind_for_unboxing -> + Reg.t array option + + (* Emit an expression in tail position of a function, closing all regions in + [env.regions] *) + method emit_tail (env : 'env environment) exp = + match exp with + | Clet (v, e1, e2) -> ( + match self#emit_expr env e1 ~bound_name:None with + | None -> () + | Some r1 -> self#emit_tail (self#bind_let env v r1) e2) + | Clet_mut (v, k, e1, e2) -> ( + match self#emit_expr env e1 ~bound_name:None with + | None -> () + | Some r1 -> self#emit_tail (self#bind_let_mut env v k r1) e2) + | Cphantom_let (_var, _defining_expr, body) -> self#emit_tail env body + | Cop ((Capply (ty, Rc_normal) as op), args, dbg) -> + self#emit_tail_apply env ty op args dbg + | Csequence (e1, e2) -> ( + match self#emit_expr env e1 ~bound_name:None with + | None -> () + | Some _ -> self#emit_tail env e2) + | Cifthenelse (econd, ifso_dbg, eif, ifnot_dbg, eelse, dbg, value_kind) -> + self#emit_tail_ifthenelse env econd ifso_dbg eif ifnot_dbg eelse dbg + value_kind + | Cswitch (esel, index, ecases, dbg, value_kind) -> + self#emit_tail_switch env esel index ecases dbg value_kind + | Ccatch (_, [], e1, _) -> self#emit_tail env e1 + | Ccatch (rec_flag, handlers, e1, value_kind) -> + self#emit_tail_catch env rec_flag handlers e1 value_kind + | Ctrywith (e1, exn_cont, v, e2, dbg, value_kind) -> + self#emit_tail_trywith env e1 exn_cont v e2 dbg value_kind + | Cop _ | Cconst_int _ | Cconst_natint _ | Cconst_float32 _ + | Cconst_float _ | Cconst_symbol _ | Cconst_vec128 _ | Cvar _ | Cassign _ + | Ctuple _ | Cexit _ -> + self#emit_return env exp (pop_all_traps env) + + method virtual emit_tail_apply + : 'env environment -> + machtype -> + operation -> + expression list -> + Debuginfo.t -> + unit + + method virtual emit_tail_ifthenelse + : 'env environment -> + expression -> + Debuginfo.t -> + expression -> + Debuginfo.t -> + expression -> + Debuginfo.t -> + kind_for_unboxing -> + unit + + method virtual emit_tail_switch + : 'env environment -> + expression -> + int array -> + (expression * Debuginfo.t) array -> + Debuginfo.t -> + kind_for_unboxing -> + unit + + method virtual emit_tail_catch + : 'env environment -> + rec_flag -> + (Lambda.static_label + * (VP.t * machtype) list + * expression + * Debuginfo.t + * bool) + list -> + expression -> + kind_for_unboxing -> + unit + + method virtual emit_tail_trywith + : 'env environment -> + expression -> + trywith_shared_label -> + VP.t -> + expression -> + Debuginfo.t -> + kind_for_unboxing -> + unit + + method virtual emit_return + : 'env environment -> expression -> trap_action list -> unit end diff --git a/backend/select_utils.mli b/backend/select_utils.mli index 41af17113e3..2b7f243f44f 100644 --- a/backend/select_utils.mli +++ b/backend/select_utils.mli @@ -196,6 +196,18 @@ class virtual ['env, 'op, 'instr] common_selector : regs:Reg.t array -> 'instr + method virtual make_const_int : nativeint -> 'op + + method virtual make_const_float32 : int32 -> 'op + + method virtual make_const_float : int64 -> 'op + + method virtual make_const_vec128 : Cmm.vec128_bits -> 'op + + method virtual make_const_symbol : Cmm.symbol -> 'op + + method virtual make_opaque : unit -> 'op + method is_simple_expr : Cmm.expression -> bool method effects_of : Cmm.expression -> Effect_and_coeffect.t @@ -248,7 +260,7 @@ class virtual ['env, 'op, 'instr] common_selector : method insert_op : 'env environment -> 'op -> Reg.t array -> Reg.t array -> Reg.t array - method virtual emit_expr : + method emit_expr : 'env environment -> Cmm.expression -> bound_name:Backend_var.With_provenance.t option -> @@ -299,4 +311,141 @@ class virtual ['env, 'op, 'instr] common_selector : Cmm.expression list -> Reg.t array -> unit + + method emit_expr : + 'env environment -> + Cmm.expression -> + bound_name:Backend_var.With_provenance.t option -> + Reg.t array option + + method emit_expr_aux : + 'env environment -> + Cmm.expression -> + bound_name:Backend_var.With_provenance.t option -> + Reg.t array option + + method virtual emit_expr_aux_raise : + 'env environment -> + Lambda.raise_kind -> + Cmm.expression -> + Debuginfo.t -> + Reg.t array option + + method virtual emit_expr_aux_op : + 'env environment -> + Backend_var.With_provenance.t option -> + Cmm.operation -> + Cmm.expression list -> + Debuginfo.t -> + Reg.t array option + + method virtual emit_expr_aux_ifthenelse : + 'env environment -> + Backend_var.With_provenance.t option -> + Cmm.expression -> + Debuginfo.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + Reg.t array option + + method virtual emit_expr_aux_switch : + 'env environment -> + Backend_var.With_provenance.t option -> + Cmm.expression -> + int array -> + (Cmm.expression * Debuginfo.t) array -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + Reg.t array option + + method virtual emit_expr_aux_catch : + 'env environment -> + Backend_var.With_provenance.t option -> + Cmm.rec_flag -> + (Lambda.static_label + * (Backend_var.With_provenance.t * Cmm.machtype) list + * Cmm.expression + * Debuginfo.t + * bool) + list -> + Cmm.expression -> + Cmm.kind_for_unboxing -> + Reg.t array option + + method virtual emit_expr_aux_exit : + 'env environment -> + Cmm.exit_label -> + Cmm.expression list -> + Cmm.trap_action list -> + Reg.t array option + + method virtual emit_expr_aux_trywith : + 'env environment -> + Backend_var.With_provenance.t option -> + Cmm.expression -> + Cmm.trywith_shared_label -> + Backend_var.With_provenance.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + Reg.t array option + + method emit_tail : 'env environment -> Cmm.expression -> unit + + method virtual emit_tail_apply : + 'env environment -> + Cmm.machtype -> + Cmm.operation -> + Cmm.expression list -> + Debuginfo.t -> + unit + + method virtual emit_tail_ifthenelse : + 'env environment -> + Cmm.expression -> + Debuginfo.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + unit + + method virtual emit_tail_switch : + 'env environment -> + Cmm.expression -> + int array -> + (Cmm.expression * Debuginfo.t) array -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + unit + + method virtual emit_tail_catch : + 'env environment -> + Cmm.rec_flag -> + (Lambda.static_label + * (Backend_var.With_provenance.t * Cmm.machtype) list + * Cmm.expression + * Debuginfo.t + * bool) + list -> + Cmm.expression -> + Cmm.kind_for_unboxing -> + unit + + method virtual emit_tail_trywith : + 'env environment -> + Cmm.expression -> + Cmm.trywith_shared_label -> + Backend_var.With_provenance.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + unit + + method virtual emit_return : + 'env environment -> Cmm.expression -> Cmm.trap_action list -> unit end diff --git a/backend/selectgen.ml b/backend/selectgen.ml index 6200794cda4..e87403bd6bc 100644 --- a/backend/selectgen.ml +++ b/backend/selectgen.ml @@ -20,7 +20,6 @@ open Cmm module Int = Numbers.Int -module V = Backend_var module VP = Backend_var.With_provenance (* The default instruction selection class *) @@ -47,6 +46,18 @@ class virtual selector_generic = (Mach.Iname_for_debugger { ident; which_parameter; provenance; is_assignment; regs }) + method make_const_int x = Mach.Iconst_int x + + method make_const_float32 x = Mach.Iconst_float32 x + + method make_const_float x = Mach.Iconst_float x + + method make_const_vec128 x = Mach.Iconst_vec128 x + + method make_const_symbol x = Mach.Iconst_symbol x + + method make_opaque () = Mach.Iopaque + (* Default instruction selection for stores (of words) *) method select_store is_assign addr arg : Mach.operation * Cmm.expression = @@ -216,152 +227,6 @@ class virtual selector_generic = if src.Reg.stamp <> dst.Reg.stamp then self#insert env Mach.(Iop Imove) [| src |] [| dst |] - (* Emit an expression. - - [bound_name] is the name that will be bound to the result of evaluating - the expression, if such exists. This is used for emitting debugging info. - - Returns: - [None] if the expression does not finish normally (e.g. - raises) - [Some rs] if the expression yields a result in registers - [rs] *) - method emit_expr (env : environment) exp ~bound_name = - self#emit_expr_aux env exp ~bound_name - - (* Emit an expression which may end some regions early. - - Returns: - [None] if the expression does not finish normally (e.g. - raises) - [Some (rs, unclosed)] if the expression yields a result in - [rs], having left [unclosed] (a suffix of env.regions) regions open *) - method emit_expr_aux (env : environment) exp ~bound_name - : Reg.t array option = - (* Normal case of returning a value: no regions are closed *) - let ret res = Some res in - match exp with - | Cconst_int (n, _dbg) -> - let r = self#regs_for typ_int in - ret - (self#insert_op env (self#make_const_int (Nativeint.of_int n)) [||] r) - | Cconst_natint (n, _dbg) -> - let r = self#regs_for typ_int in - ret (self#insert_op env (self#make_const_int n) [||] r) - | Cconst_float32 (n, _dbg) -> - let r = self#regs_for typ_float32 in - ret - (self#insert_op env - (self#make_const_float32 (Int32.bits_of_float n)) - [||] r) - | Cconst_float (n, _dbg) -> - let r = self#regs_for typ_float in - ret - (self#insert_op env - (self#make_const_float (Int64.bits_of_float n)) - [||] r) - | Cconst_vec128 (bits, _dbg) -> - let r = self#regs_for typ_vec128 in - ret (self#insert_op env (self#make_const_vec128 bits) [||] r) - | Cconst_symbol (n, _dbg) -> - (* Cconst_symbol _ evaluates to a statically-allocated address, so its - value fits in a typ_int register and is never changed by the GC. - - Some Cconst_symbols point to statically-allocated blocks, some of - which may point to heap values. However, any such blocks will be - registered in the compilation unit's global roots structure, so - adding this register to the frame table would be redundant *) - let r = self#regs_for typ_int in - ret (self#insert_op env (self#make_const_symbol n) [||] r) - | Cvar v -> ( - try ret (Select_utils.env_find v env) - with Not_found -> - Misc.fatal_error - ("Selection.emit_expr: unbound var " ^ V.unique_name v)) - | Clet (v, e1, e2) -> ( - match self#emit_expr env e1 ~bound_name:(Some v) with - | None -> None - | Some r1 -> self#emit_expr_aux (self#bind_let env v r1) e2 ~bound_name) - | Clet_mut (v, k, e1, e2) -> ( - match self#emit_expr env e1 ~bound_name:(Some v) with - | None -> None - | Some r1 -> - self#emit_expr_aux (self#bind_let_mut env v k r1) e2 ~bound_name) - | Cphantom_let (_var, _defining_expr, body) -> - self#emit_expr_aux env body ~bound_name - | Cassign (v, e1) -> ( - let rv, provenance = - try Select_utils.env_find_mut v env - with Not_found -> - Misc.fatal_error ("Selection.emit_expr: unbound var " ^ V.name v) - in - match self#emit_expr env e1 ~bound_name:None with - | None -> None - | Some r1 -> - (if Option.is_some provenance - then - let naming_op = - self#make_name_for_debugger ~ident:v ~provenance - ~which_parameter:None ~is_assignment:true ~regs:r1 - in - self#insert_debug env naming_op Debuginfo.none [||] [||]); - self#insert_moves env r1 rv; - ret [||]) - | Ctuple [] -> ret [||] - | Ctuple exp_list -> ( - match self#emit_parts_list env exp_list with - | None -> None - | Some (simple_list, ext_env) -> - ret (self#emit_tuple ext_env simple_list)) - | Cop (Craise k, [arg], dbg) -> self#emit_expr_aux_raise env k arg dbg - | Cop (Copaque, args, dbg) -> ( - match self#emit_parts_list env args with - | None -> None - | Some (simple_args, env) -> - let rs = self#emit_tuple env simple_args in - ret (self#insert_op_debug env (self#make_opaque ()) dbg rs rs)) - | Cop (Ctuple_field (field, fields_layout), [arg], _dbg) -> ( - match self#emit_expr env arg ~bound_name:None with - | None -> None - | Some loc_exp -> - let flat_size a = - Array.fold_left (fun acc t -> acc + Array.length t) 0 a - in - assert (Array.length loc_exp = flat_size fields_layout); - let before = Array.sub fields_layout 0 field in - let size_before = flat_size before in - let field_slice = - Array.sub loc_exp size_before (Array.length fields_layout.(field)) - in - ret field_slice) - | Cop (op, args, dbg) -> self#emit_expr_aux_op env bound_name op args dbg - | Csequence (e1, e2) -> ( - match self#emit_expr env e1 ~bound_name:None with - | None -> None - | Some _ -> self#emit_expr_aux env e2 ~bound_name) - | Cifthenelse (econd, ifso_dbg, eif, ifnot_dbg, eelse, dbg, value_kind) -> - self#emit_expr_aux_ifthenelse env bound_name econd ifso_dbg eif - ifnot_dbg eelse dbg value_kind - | Cswitch (esel, index, ecases, dbg, value_kind) -> - self#emit_expr_aux_switch env bound_name esel index ecases dbg - value_kind - | Ccatch (_, [], e1, _) -> self#emit_expr_aux env e1 ~bound_name - | Ccatch (rec_flag, handlers, body, value_kind) -> - self#emit_expr_aux_catch env bound_name rec_flag handlers body - value_kind - | Cexit (lbl, args, traps) -> self#emit_expr_aux_exit env lbl args traps - | Ctrywith (e1, exn_cont, v, e2, dbg, value_kind) -> - self#emit_expr_aux_trywith env bound_name e1 exn_cont v e2 dbg - value_kind - - method private make_const_int x = Mach.Iconst_int x - - method private make_const_float32 x = Mach.Iconst_float32 x - - method private make_const_float x = Mach.Iconst_float x - - method private make_const_vec128 x = Mach.Iconst_vec128 x - - method private make_const_symbol x = Mach.Iconst_symbol x - - method private make_opaque () = Mach.Iopaque - method private emit_expr_aux_raise env k arg dbg = match self#emit_expr env arg ~bound_name:None with | None -> None @@ -748,40 +613,6 @@ class virtual selector_generic = method private emit_return (env : environment) exp traps = self#insert_return env (self#emit_expr_aux env exp ~bound_name:None) traps - (* Emit an expression in tail position of a function, closing all regions in - [env.regions] *) - method emit_tail (env : environment) exp = - match exp with - | Clet (v, e1, e2) -> ( - match self#emit_expr env e1 ~bound_name:None with - | None -> () - | Some r1 -> self#emit_tail (self#bind_let env v r1) e2) - | Clet_mut (v, k, e1, e2) -> ( - match self#emit_expr env e1 ~bound_name:None with - | None -> () - | Some r1 -> self#emit_tail (self#bind_let_mut env v k r1) e2) - | Cphantom_let (_var, _defining_expr, body) -> self#emit_tail env body - | Cop ((Capply (ty, Rc_normal) as op), args, dbg) -> - self#emit_tail_apply env ty op args dbg - | Csequence (e1, e2) -> ( - match self#emit_expr env e1 ~bound_name:None with - | None -> () - | Some _ -> self#emit_tail env e2) - | Cifthenelse (econd, ifso_dbg, eif, ifnot_dbg, eelse, dbg, value_kind) -> - self#emit_tail_ifthenelse env econd ifso_dbg eif ifnot_dbg eelse dbg - value_kind - | Cswitch (esel, index, ecases, dbg, value_kind) -> - self#emit_tail_switch env esel index ecases dbg value_kind - | Ccatch (_, [], e1, _) -> self#emit_tail env e1 - | Ccatch (rec_flag, handlers, e1, value_kind) -> - self#emit_tail_catch env rec_flag handlers e1 value_kind - | Ctrywith (e1, exn_cont, v, e2, dbg, value_kind) -> - self#emit_tail_trywith env e1 exn_cont v e2 dbg value_kind - | Cop _ | Cconst_int _ | Cconst_natint _ | Cconst_float32 _ - | Cconst_float _ | Cconst_symbol _ | Cconst_vec128 _ | Cvar _ | Cassign _ - | Ctuple _ | Cexit _ -> - self#emit_return env exp (Select_utils.pop_all_traps env) - method private emit_tail_apply env ty op args dbg = match self#emit_parts_list env args with | None -> () diff --git a/backend/selectgen.mli b/backend/selectgen.mli index b5776ea2726..1bf1dc6b169 100644 --- a/backend/selectgen.mli +++ b/backend/selectgen.mli @@ -39,6 +39,18 @@ class virtual selector_generic : regs:Reg.t array -> Mach.instruction_desc + method make_const_int : nativeint -> Mach.operation + + method make_const_float32 : int32 -> Mach.operation + + method make_const_float : int64 -> Mach.operation + + method make_const_vec128 : Cmm.vec128_bits -> Mach.operation + + method make_const_symbol : Cmm.symbol -> Mach.operation + + method make_opaque : unit -> Mach.operation + (* The following methods must or can be overridden by the processor description *) method is_immediate : Mach.integer_operation -> int -> bool @@ -185,8 +197,131 @@ class virtual selector_generic : bound_name:Backend_var.With_provenance.t option -> Reg.t array option + method emit_expr_aux_raise : + environment -> + Lambda.raise_kind -> + Cmm.expression -> + Debuginfo.t -> + Reg.t array option + + method emit_expr_aux_op : + environment -> + Backend_var.With_provenance.t option -> + Cmm.operation -> + Cmm.expression list -> + Debuginfo.t -> + Reg.t array option + + method emit_expr_aux_ifthenelse : + environment -> + Backend_var.With_provenance.t option -> + Cmm.expression -> + Debuginfo.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + Reg.t array option + + method emit_expr_aux_switch : + environment -> + Backend_var.With_provenance.t option -> + Cmm.expression -> + int array -> + (Cmm.expression * Debuginfo.t) array -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + Reg.t array option + + method emit_expr_aux_catch : + environment -> + Backend_var.With_provenance.t option -> + Cmm.rec_flag -> + (Lambda.static_label + * (Backend_var.With_provenance.t * Cmm.machtype) list + * Cmm.expression + * Debuginfo.t + * bool) + list -> + Cmm.expression -> + Cmm.kind_for_unboxing -> + Reg.t array option + + method emit_expr_aux_exit : + environment -> + Cmm.exit_label -> + Cmm.expression list -> + Cmm.trap_action list -> + Reg.t array option + + method emit_expr_aux_trywith : + environment -> + Backend_var.With_provenance.t option -> + Cmm.expression -> + Cmm.trywith_shared_label -> + Backend_var.With_provenance.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + Reg.t array option + method emit_tail : environment -> Cmm.expression -> unit + method emit_tail_apply : + environment -> + Cmm.machtype -> + Cmm.operation -> + Cmm.expression list -> + Debuginfo.t -> + unit + + method emit_tail_ifthenelse : + environment -> + Cmm.expression -> + Debuginfo.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + unit + + method emit_tail_switch : + environment -> + Cmm.expression -> + int array -> + (Cmm.expression * Debuginfo.t) array -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + unit + + method emit_tail_catch : + environment -> + Cmm.rec_flag -> + (Lambda.static_label + * (Backend_var.With_provenance.t * Cmm.machtype) list + * Cmm.expression + * Debuginfo.t + * bool) + list -> + Cmm.expression -> + Cmm.kind_for_unboxing -> + unit + + method emit_tail_trywith : + environment -> + Cmm.expression -> + Cmm.trywith_shared_label -> + Backend_var.With_provenance.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + unit + + method emit_return : + environment -> Cmm.expression -> Cmm.trap_action list -> unit + (* [contains_calls] is declared as a reference instance variable, instead of a mutable boolean instance variable, because the traversal uses functional object copies. *) From 10cd7a107d3b1783c6e383931d132edbb9d48a07 Mon Sep 17 00:00:00 2001 From: Xavier Clerc Date: Wed, 18 Sep 2024 10:18:17 +0100 Subject: [PATCH 52/76] Selection: split the architecture-dependent modules (#3013) --- backend/.ocamlformat-enable | 2 + backend/amd64/selection.ml | 180 +--------------------------- backend/amd64/selection_utils.ml | 198 +++++++++++++++++++++++++++++++ backend/arm64/selection.ml | 46 +------ backend/arm64/selection_utils.ml | 63 ++++++++++ backend/dune | 2 +- dune | 1 + 7 files changed, 268 insertions(+), 224 deletions(-) create mode 100644 backend/amd64/selection_utils.ml create mode 100644 backend/arm64/selection_utils.ml diff --git a/backend/.ocamlformat-enable b/backend/.ocamlformat-enable index 5ce70f4f3ba..e7691489d5e 100644 --- a/backend/.ocamlformat-enable +++ b/backend/.ocamlformat-enable @@ -1,7 +1,9 @@ amd64/selection.ml +amd64/selection_utils.ml amd64/simd*.ml amd64/stack_check.ml arm64/selection.ml +arm64/selection_utils.ml arm64/simd*.ml arm64/stack_check.ml asm_targets/**/*.ml diff --git a/backend/amd64/selection.ml b/backend/amd64/selection.ml index 437cc2ef0c8..d915fcac62a 100644 --- a/backend/amd64/selection.ml +++ b/backend/amd64/selection.ml @@ -18,185 +18,7 @@ open Arch open Proc open Cmm - -(* Auxiliary for recognizing addressing modes *) - -type addressing_expr = - | Asymbol of Cmm.symbol - | Alinear of expression - | Aadd of expression * expression - | Ascale of expression * int - | Ascaledadd of expression * expression * int - -let rec select_addr exp = - let default = Alinear exp, 0 in - match exp with - | Cconst_symbol (s, _) when not !Clflags.dlcode -> Asymbol s, 0 - | Cop ((Caddi | Caddv | Cadda), [arg; Cconst_int (m, _)], _) - | Cop ((Caddi | Caddv | Cadda), [Cconst_int (m, _); arg], _) -> - let a, n = select_addr arg in - if Misc.no_overflow_add n m then a, n + m else default - | Cop (Csubi, [arg; Cconst_int (m, _)], _) -> - let a, n = select_addr arg in - if Misc.no_overflow_sub n m then a, n - m else default - | Cop (Clsl, [arg; Cconst_int (((1 | 2 | 3) as shift), _)], _) -> ( - let default = Ascale (arg, 1 lsl shift), 0 in - match select_addr arg with - | Alinear e, n -> - if Misc.no_overflow_lsl n shift - then Ascale (e, 1 lsl shift), n lsl shift - else default - | (Asymbol _ | Aadd (_, _) | Ascale (_, _) | Ascaledadd (_, _, _)), _ -> - default) - | Cop (Cmuli, [arg; Cconst_int (((2 | 4 | 8) as mult), _)], _) - | Cop (Cmuli, [Cconst_int (((2 | 4 | 8) as mult), _); arg], _) -> ( - let default = Ascale (arg, mult), 0 in - match select_addr arg with - | Alinear e, n -> - if Misc.no_overflow_mul n mult - then Ascale (e, mult), n * mult - else default - | (Asymbol _ | Aadd (_, _) | Ascale (_, _) | Ascaledadd (_, _, _)), _ -> - default) - | Cop ((Caddi | Caddv | Cadda), [arg1; arg2], _) -> ( - match select_addr arg1, select_addr arg2 with - | (Alinear e1, n1), (Alinear e2, n2) when Misc.no_overflow_add n1 n2 -> - Aadd (e1, e2), n1 + n2 - | (Alinear e1, n1), (Ascale (e2, scale), n2) - | (Ascale (e2, scale), n2), (Alinear e1, n1) - when Misc.no_overflow_add n1 n2 -> - Ascaledadd (e1, e2, scale), n1 + n2 - | _, (Ascale (e2, scale), n2) -> Ascaledadd (arg1, e2, scale), n2 - | (Ascale (e1, scale), n1), _ -> Ascaledadd (arg2, e1, scale), n1 - | ( (Alinear _, _), - ((Alinear _ | Asymbol _ | Aadd (_, _) | Ascaledadd (_, _, _)), _) ) - | ( ((Asymbol _ | Aadd (_, _) | Ascaledadd (_, _, _)), _), - ((Asymbol _ | Alinear _ | Aadd (_, _) | Ascaledadd (_, _, _)), _) ) -> - Aadd (arg1, arg2), 0) - | _ -> default - -(* Special constraints on operand and result registers *) - -exception Use_default - -let rax = phys_reg Int 0 - -let rcx = phys_reg Int 5 - -let rdx = phys_reg Int 4 - -let _xmm0v () = phys_reg Vec128 100 - -let pseudoregs_for_operation op arg res = - match (op : Mach.operation) with - (* Two-address binary operations: arg.(0) and res.(0) must be the same *) - | Iintop (Iadd | Isub | Imul | Iand | Ior | Ixor) - | Ifloatop ((Float32 | Float64), (Iaddf | Isubf | Imulf | Idivf)) -> - [| res.(0); arg.(1) |], res - | Iintop_atomic { op = Compare_and_swap; size = _; addr = _ } -> - (* first arg must be rax *) - let arg = Array.copy arg in - arg.(0) <- rax; - arg, res - | Iintop_atomic { op = Fetch_and_add; size = _; addr = _ } -> - (* first arg must be the same as res.(0) *) - let arg = Array.copy arg in - arg.(0) <- res.(0); - arg, res - (* One-address unary operations: arg.(0) and res.(0) must be the same *) - | Iintop_imm ((Iadd | Isub | Imul | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr), _) - | Ifloatop ((Float64 | Float32), (Iabsf | Inegf)) - | Ispecific (Ibswap { bitwidth = Thirtytwo | Sixtyfour }) -> - res, res - (* For xchg, args must be a register allowing access to high 8 bit register - (rax, rbx, rcx or rdx). Keep it simple, just force the argument in rax. *) - | Ispecific (Ibswap { bitwidth = Sixteen }) -> [| rax |], [| rax |] - (* For imulh, first arg must be in rax, rax is clobbered, and result is in - rdx. *) - | Iintop (Imulh _) -> [| rax; arg.(1) |], [| rdx |] - | Ispecific (Ifloatarithmem (_, _, _)) -> - let arg' = Array.copy arg in - arg'.(0) <- res.(0); - arg', res - (* For shifts with variable shift count, second arg must be in rcx *) - | Iintop (Ilsl | Ilsr | Iasr) -> [| res.(0); rcx |], res - (* For div and mod, first arg must be in rax, rdx is clobbered, and result is - in rax or rdx respectively. Keep it simple, just force second argument in - rcx. *) - | Iintop Idiv -> [| rax; rcx |], [| rax |] - | Iintop Imod -> [| rax; rcx |], [| rdx |] - | Ifloatop (Float64, Icompf cond) -> - (* CR gyorsh: make this optimization as a separate PR. *) - (* We need to temporarily store the result of the comparison in a float - register, but we don't want to clobber any of the inputs if they would - still be live after this operation -- so we add a fresh register as both - an input and output. We don't use [destroyed_at_oper], because that - forces us to choose a fixed register, which makes it more likely an extra - mov would be added to transfer the argument to the fixed register. *) - let treg = Reg.create Float in - let _, is_swapped = float_cond_and_need_swap cond in - ( (if is_swapped then [| arg.(0); treg |] else [| treg; arg.(1) |]), - [| res.(0); treg |] ) - | Ifloatop (Float32, Icompf cond) -> - let treg = Reg.create Float32 in - let _, is_swapped = float_cond_and_need_swap cond in - ( (if is_swapped then [| arg.(0); treg |] else [| treg; arg.(1) |]), - [| res.(0); treg |] ) - | Ispecific Irdpmc -> - (* For rdpmc instruction, the argument must be in ecx and the result is in - edx (high) and eax (low). Make it simple and force the argument in rcx, - and rax and rdx clobbered *) - [| rcx |], res - | Ispecific (Isimd op) -> Simd_selection.pseudoregs_for_operation op arg res - | Icsel _ -> - (* last arg must be the same as res.(0) *) - let len = Array.length arg in - let arg = Array.copy arg in - arg.(len - 1) <- res.(0); - arg, res - (* Other instructions are regular *) - | Iintop (Ipopcnt | Iclz _ | Ictz _ | Icomp _) - | Iintop_imm ((Imulh _ | Idiv | Imod | Icomp _ | Ipopcnt | Iclz _ | Ictz _), _) - | Ispecific - ( Isextend32 | Izextend32 | Ilea _ - | Istore_int (_, _, _) - | Ipause | Ilfence | Isfence | Imfence - | Ioffset_loc (_, _) - | Irdtsc | Iprefetch _ ) - | Imove | Ispill | Ireload | Ireinterpret_cast _ | Istatic_cast _ - | Iconst_int _ | Iconst_float32 _ | Iconst_float _ | Iconst_vec128 _ - | Iconst_symbol _ | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ - | Iextcall _ | Istackoffset _ | Iload _ - | Istore (_, _, _) - | Ialloc _ | Iname_for_debugger _ | Iprobe _ | Iprobe_is_enabled _ | Iopaque - | Ibeginregion | Iendregion | Ipoll _ | Idls_get -> - raise Use_default - -let select_locality (l : Cmm.prefetch_temporal_locality_hint) : - Arch.prefetch_temporal_locality_hint = - match l with - | Nonlocal -> Nonlocal - | Low -> Low - | Moderate -> Moderate - | High -> High - -let select_bitwidth : Cmm.bswap_bitwidth -> Arch.bswap_bitwidth = function - | Sixteen -> Sixteen - | Thirtytwo -> Thirtytwo - | Sixtyfour -> Sixtyfour - -let one_arg name args = - match args with - | [arg] -> arg - | _ -> Misc.fatal_errorf "Selection: expected exactly 1 argument for %s" name - -(* If you update [inline_ops], you may need to update [is_simple_expr] and/or - [effects_of], below. *) -let inline_ops = ["sqrt"] - -let is_immediate n = n <= 0x7FFF_FFFF && n >= -0x8000_0000 - -let is_immediate_natint n = n <= 0x7FFF_FFFFn && n >= -0x8000_0000n +open Selection_utils (* The selector class *) diff --git a/backend/amd64/selection_utils.ml b/backend/amd64/selection_utils.ml new file mode 100644 index 00000000000..e1a0e367b2b --- /dev/null +++ b/backend/amd64/selection_utils.ml @@ -0,0 +1,198 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Instruction selection for the AMD64 *) + +open Arch +open Proc + +(* Auxiliary for recognizing addressing modes *) + +type addressing_expr = + | Asymbol of Cmm.symbol + | Alinear of Cmm.expression + | Aadd of Cmm.expression * Cmm.expression + | Ascale of Cmm.expression * int + | Ascaledadd of Cmm.expression * Cmm.expression * int + +let rec select_addr exp = + let default = Alinear exp, 0 in + match exp with + | Cmm.Cconst_symbol (s, _) when not !Clflags.dlcode -> Asymbol s, 0 + | Cmm.Cop ((Caddi | Caddv | Cadda), [arg; Cconst_int (m, _)], _) + | Cmm.Cop ((Caddi | Caddv | Cadda), [Cconst_int (m, _); arg], _) -> + let a, n = select_addr arg in + if Misc.no_overflow_add n m then a, n + m else default + | Cmm.Cop (Csubi, [arg; Cconst_int (m, _)], _) -> + let a, n = select_addr arg in + if Misc.no_overflow_sub n m then a, n - m else default + | Cmm.Cop (Clsl, [arg; Cconst_int (((1 | 2 | 3) as shift), _)], _) -> ( + let default = Ascale (arg, 1 lsl shift), 0 in + match select_addr arg with + | Alinear e, n -> + if Misc.no_overflow_lsl n shift + then Ascale (e, 1 lsl shift), n lsl shift + else default + | (Asymbol _ | Aadd (_, _) | Ascale (_, _) | Ascaledadd (_, _, _)), _ -> + default) + | Cmm.Cop (Cmuli, [arg; Cconst_int (((2 | 4 | 8) as mult), _)], _) + | Cmm.Cop (Cmuli, [Cconst_int (((2 | 4 | 8) as mult), _); arg], _) -> ( + let default = Ascale (arg, mult), 0 in + match select_addr arg with + | Alinear e, n -> + if Misc.no_overflow_mul n mult + then Ascale (e, mult), n * mult + else default + | (Asymbol _ | Aadd (_, _) | Ascale (_, _) | Ascaledadd (_, _, _)), _ -> + default) + | Cmm.Cop ((Caddi | Caddv | Cadda), [arg1; arg2], _) -> ( + match select_addr arg1, select_addr arg2 with + | (Alinear e1, n1), (Alinear e2, n2) when Misc.no_overflow_add n1 n2 -> + Aadd (e1, e2), n1 + n2 + | (Alinear e1, n1), (Ascale (e2, scale), n2) + | (Ascale (e2, scale), n2), (Alinear e1, n1) + when Misc.no_overflow_add n1 n2 -> + Ascaledadd (e1, e2, scale), n1 + n2 + | _, (Ascale (e2, scale), n2) -> Ascaledadd (arg1, e2, scale), n2 + | (Ascale (e1, scale), n1), _ -> Ascaledadd (arg2, e1, scale), n1 + | ( (Alinear _, _), + ((Alinear _ | Asymbol _ | Aadd (_, _) | Ascaledadd (_, _, _)), _) ) + | ( ((Asymbol _ | Aadd (_, _) | Ascaledadd (_, _, _)), _), + ((Asymbol _ | Alinear _ | Aadd (_, _) | Ascaledadd (_, _, _)), _) ) -> + Aadd (arg1, arg2), 0) + | _ -> default + +(* Special constraints on operand and result registers *) + +exception Use_default + +let rax = phys_reg Int 0 + +let rcx = phys_reg Int 5 + +let rdx = phys_reg Int 4 + +let _xmm0v () = phys_reg Vec128 100 + +let pseudoregs_for_operation op arg res = + match (op : Mach.operation) with + (* Two-address binary operations: arg.(0) and res.(0) must be the same *) + | Iintop (Iadd | Isub | Imul | Iand | Ior | Ixor) + | Ifloatop ((Float32 | Float64), (Iaddf | Isubf | Imulf | Idivf)) -> + [| res.(0); arg.(1) |], res + | Iintop_atomic { op = Compare_and_swap; size = _; addr = _ } -> + (* first arg must be rax *) + let arg = Array.copy arg in + arg.(0) <- rax; + arg, res + | Iintop_atomic { op = Fetch_and_add; size = _; addr = _ } -> + (* first arg must be the same as res.(0) *) + let arg = Array.copy arg in + arg.(0) <- res.(0); + arg, res + (* One-address unary operations: arg.(0) and res.(0) must be the same *) + | Iintop_imm ((Iadd | Isub | Imul | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr), _) + | Ifloatop ((Float64 | Float32), (Iabsf | Inegf)) + | Ispecific (Ibswap { bitwidth = Thirtytwo | Sixtyfour }) -> + res, res + (* For xchg, args must be a register allowing access to high 8 bit register + (rax, rbx, rcx or rdx). Keep it simple, just force the argument in rax. *) + | Ispecific (Ibswap { bitwidth = Sixteen }) -> [| rax |], [| rax |] + (* For imulh, first arg must be in rax, rax is clobbered, and result is in + rdx. *) + | Iintop (Imulh _) -> [| rax; arg.(1) |], [| rdx |] + | Ispecific (Ifloatarithmem (_, _, _)) -> + let arg' = Array.copy arg in + arg'.(0) <- res.(0); + arg', res + (* For shifts with variable shift count, second arg must be in rcx *) + | Iintop (Ilsl | Ilsr | Iasr) -> [| res.(0); rcx |], res + (* For div and mod, first arg must be in rax, rdx is clobbered, and result is + in rax or rdx respectively. Keep it simple, just force second argument in + rcx. *) + | Iintop Idiv -> [| rax; rcx |], [| rax |] + | Iintop Imod -> [| rax; rcx |], [| rdx |] + | Ifloatop (Float64, Icompf cond) -> + (* CR gyorsh: make this optimization as a separate PR. *) + (* We need to temporarily store the result of the comparison in a float + register, but we don't want to clobber any of the inputs if they would + still be live after this operation -- so we add a fresh register as both + an input and output. We don't use [destroyed_at_oper], because that + forces us to choose a fixed register, which makes it more likely an extra + mov would be added to transfer the argument to the fixed register. *) + let treg = Reg.create Float in + let _, is_swapped = float_cond_and_need_swap cond in + ( (if is_swapped then [| arg.(0); treg |] else [| treg; arg.(1) |]), + [| res.(0); treg |] ) + | Ifloatop (Float32, Icompf cond) -> + let treg = Reg.create Float32 in + let _, is_swapped = float_cond_and_need_swap cond in + ( (if is_swapped then [| arg.(0); treg |] else [| treg; arg.(1) |]), + [| res.(0); treg |] ) + | Ispecific Irdpmc -> + (* For rdpmc instruction, the argument must be in ecx and the result is in + edx (high) and eax (low). Make it simple and force the argument in rcx, + and rax and rdx clobbered *) + [| rcx |], res + | Ispecific (Isimd op) -> Simd_selection.pseudoregs_for_operation op arg res + | Icsel _ -> + (* last arg must be the same as res.(0) *) + let len = Array.length arg in + let arg = Array.copy arg in + arg.(len - 1) <- res.(0); + arg, res + (* Other instructions are regular *) + | Iintop (Ipopcnt | Iclz _ | Ictz _ | Icomp _) + | Iintop_imm ((Imulh _ | Idiv | Imod | Icomp _ | Ipopcnt | Iclz _ | Ictz _), _) + | Ispecific + ( Isextend32 | Izextend32 | Ilea _ + | Istore_int (_, _, _) + | Ipause | Ilfence | Isfence | Imfence + | Ioffset_loc (_, _) + | Irdtsc | Iprefetch _ ) + | Imove | Ispill | Ireload | Ireinterpret_cast _ | Istatic_cast _ + | Iconst_int _ | Iconst_float32 _ | Iconst_float _ | Iconst_vec128 _ + | Iconst_symbol _ | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Iload _ + | Istore (_, _, _) + | Ialloc _ | Iname_for_debugger _ | Iprobe _ | Iprobe_is_enabled _ | Iopaque + | Ibeginregion | Iendregion | Ipoll _ | Idls_get -> + raise Use_default + +let select_locality (l : Cmm.prefetch_temporal_locality_hint) : + Arch.prefetch_temporal_locality_hint = + match l with + | Nonlocal -> Nonlocal + | Low -> Low + | Moderate -> Moderate + | High -> High + +let select_bitwidth : Cmm.bswap_bitwidth -> Arch.bswap_bitwidth = function + | Sixteen -> Sixteen + | Thirtytwo -> Thirtytwo + | Sixtyfour -> Sixtyfour + +let one_arg name args = + match args with + | [arg] -> arg + | _ -> Misc.fatal_errorf "Selection: expected exactly 1 argument for %s" name + +(* If you update [inline_ops], you may need to update [is_simple_expr] and/or + [effects_of], below. *) +let inline_ops = ["sqrt"] + +let is_immediate n = n <= 0x7FFF_FFFF && n >= -0x8000_0000 + +let is_immediate_natint n = n <= 0x7FFF_FFFFn && n >= -0x8000_0000n diff --git a/backend/arm64/selection.ml b/backend/arm64/selection.ml index 76cc5157ecc..3dc27261166 100644 --- a/backend/arm64/selection.ml +++ b/backend/arm64/selection.ml @@ -19,49 +19,7 @@ open Arch open Cmm - -let is_offset chunk n = - (n >= -256 && n <= 255) (* 9 bits signed unscaled *) - || n >= 0 - && - match chunk with - (* 12 bits unsigned, scaled by chunk size *) - | Byte_unsigned | Byte_signed -> n < 0x1000 - | Sixteen_unsigned | Sixteen_signed -> n land 1 = 0 && n lsr 1 < 0x1000 - | Thirtytwo_unsigned | Thirtytwo_signed | Single { reg = Float64 } -> - n land 3 = 0 && n lsr 2 < 0x1000 - | Word_int | Word_val | Double -> n land 7 = 0 && n lsr 3 < 0x1000 - | Onetwentyeight_aligned | Onetwentyeight_unaligned -> - (* CR mslater: (SIMD) arm64 *) - Misc.fatal_error "arm64: got 128 bit memory chunk" - | Single { reg = Float32 } -> - (* CR mslater: (float32) arm64 *) - Misc.fatal_error "arm64: got float32 memory chunk" - -let is_logical_immediate n = Arch.is_logical_immediate (Nativeint.of_int n) - -(* Signed immediates are simpler *) - -let is_immediate n = - let mn = -n in - n land 0xFFF = n - || n land 0xFFF_000 = n - || mn land 0xFFF = mn - || mn land 0xFFF_000 = mn - -(* If you update [inline_ops], you may need to update [is_simple_expr] and/or - [effects_of], below. *) -let inline_ops = ["sqrt"] - -let use_direct_addressing _symb = (not !Clflags.dlcode) && not Arch.macosx - -let is_stack_slot rv = - Reg.(match rv with [| { loc = Stack _ } |] -> true | _ -> false) - -let select_bitwidth : Cmm.bswap_bitwidth -> Arch.bswap_bitwidth = function - | Sixteen -> Sixteen - | Thirtytwo -> Thirtytwo - | Sixtyfour -> Sixtyfour +open Selection_utils (* Instruction selection *) @@ -74,7 +32,7 @@ class selector = method! is_immediate op n = match op with | Iadd | Isub -> n <= 0xFFF_FFF && n >= -0xFFF_FFF - | Iand | Ior | Ixor -> is_logical_immediate n + | Iand | Ior | Ixor -> is_logical_immediate_int n | Icomp _ -> is_immediate n | _ -> super#is_immediate op n diff --git a/backend/arm64/selection_utils.ml b/backend/arm64/selection_utils.ml new file mode 100644 index 00000000000..d04b48e4f9a --- /dev/null +++ b/backend/arm64/selection_utils.ml @@ -0,0 +1,63 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2012 Benedikt Meurer. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Instruction selection for the ARM processor *) + +open Arch + +let is_offset chunk n = + (n >= -256 && n <= 255) (* 9 bits signed unscaled *) + || n >= 0 + && + match (chunk : Cmm.memory_chunk) with + (* 12 bits unsigned, scaled by chunk size *) + | Byte_unsigned | Byte_signed -> n < 0x1000 + | Sixteen_unsigned | Sixteen_signed -> n land 1 = 0 && n lsr 1 < 0x1000 + | Thirtytwo_unsigned | Thirtytwo_signed | Single { reg = Float64 } -> + n land 3 = 0 && n lsr 2 < 0x1000 + | Word_int | Word_val | Double -> n land 7 = 0 && n lsr 3 < 0x1000 + | Onetwentyeight_aligned | Onetwentyeight_unaligned -> + (* CR mslater: (SIMD) arm64 *) + Misc.fatal_error "arm64: got 128 bit memory chunk" + | Single { reg = Float32 } -> + (* CR mslater: (float32) arm64 *) + Misc.fatal_error "arm64: got float32 memory chunk" + +let is_logical_immediate_int n = Arch.is_logical_immediate (Nativeint.of_int n) + +(* Signed immediates are simpler *) + +let is_immediate n = + let mn = -n in + n land 0xFFF = n + || n land 0xFFF_000 = n + || mn land 0xFFF = mn + || mn land 0xFFF_000 = mn + +(* If you update [inline_ops], you may need to update [is_simple_expr] and/or + [effects_of], below. *) +let inline_ops = ["sqrt"] + +let use_direct_addressing _symb = (not !Clflags.dlcode) && not Arch.macosx + +let is_stack_slot rv = + Reg.(match rv with [| { loc = Stack _ } |] -> true | _ -> false) + +let select_bitwidth : Cmm.bswap_bitwidth -> Arch.bswap_bitwidth = function + | Sixteen -> Sixteen + | Thirtytwo -> Thirtytwo + | Sixtyfour -> Sixtyfour diff --git a/backend/dune b/backend/dune index 27bacf793dd..c00bc9a5ac0 100644 --- a/backend/dune +++ b/backend/dune @@ -14,7 +14,7 @@ (rule (targets arch.ml arch.mli CSE.ml proc.ml regalloc_stack_operands.ml reload.ml selection.ml - simd.ml simd_selection.ml simd_reload.ml simd_proc.ml stack_check.ml) + selection_utils.ml simd.ml simd_selection.ml simd_reload.ml simd_proc.ml stack_check.ml) (mode fallback) (deps (glob_files amd64/*.ml) (glob_files amd64/*.mli) diff --git a/dune b/dune index 788de1da444..1eb2acec52f 100755 --- a/dune +++ b/dune @@ -137,6 +137,7 @@ select_utils selectgen selection + selection_utils spill split string_table From 1e9f6cac3ec41cc2346fa5b24976ed241b72a34c Mon Sep 17 00:00:00 2001 From: Xavier Clerc Date: Wed, 18 Sep 2024 11:06:03 +0100 Subject: [PATCH 53/76] Selection: enable warnings in architecture-dependent modules (#3014) --- backend/amd64/selection.ml | 5 +++-- backend/amd64/selection_utils.ml | 2 ++ backend/arm64/selection.ml | 2 ++ backend/arm64/selection_utils.ml | 2 ++ 4 files changed, 9 insertions(+), 2 deletions(-) diff --git a/backend/amd64/selection.ml b/backend/amd64/selection.ml index d915fcac62a..ae71a985ef8 100644 --- a/backend/amd64/selection.ml +++ b/backend/amd64/selection.ml @@ -15,9 +15,9 @@ (* Instruction selection for the AMD64 *) +[@@@ocaml.warning "+a-4-9-40-41-42"] + open Arch -open Proc -open Cmm open Selection_utils (* The selector class *) @@ -192,6 +192,7 @@ class selector = (* Recognize float arithmetic with mem *) method select_floatarith commutative width regular_op mem_op args = + let open Cmm in match width, args with | ( Float64, [arg1; Cop (Cload { memory_chunk = Double as chunk; _ }, [loc2], _)] ) diff --git a/backend/amd64/selection_utils.ml b/backend/amd64/selection_utils.ml index e1a0e367b2b..19249cbe884 100644 --- a/backend/amd64/selection_utils.ml +++ b/backend/amd64/selection_utils.ml @@ -15,6 +15,8 @@ (* Instruction selection for the AMD64 *) +[@@@ocaml.warning "+a-4-9-40-41-42"] + open Arch open Proc diff --git a/backend/arm64/selection.ml b/backend/arm64/selection.ml index 3dc27261166..ee57ee21c77 100644 --- a/backend/arm64/selection.ml +++ b/backend/arm64/selection.ml @@ -17,6 +17,8 @@ (* Instruction selection for the ARM processor *) +[@@@ocaml.warning "+a-4-9-40-41-42"] + open Arch open Cmm open Selection_utils diff --git a/backend/arm64/selection_utils.ml b/backend/arm64/selection_utils.ml index d04b48e4f9a..97806929e43 100644 --- a/backend/arm64/selection_utils.ml +++ b/backend/arm64/selection_utils.ml @@ -17,6 +17,8 @@ (* Instruction selection for the ARM processor *) +[@@@ocaml.warning "+a-4-9-40-41-42"] + open Arch let is_offset chunk n = From 9ef9c33bbd17d67aa3501990c9fd51d4ff8b587f Mon Sep 17 00:00:00 2001 From: Xavier Clerc Date: Wed, 18 Sep 2024 11:42:40 +0100 Subject: [PATCH 54/76] Selection: CFG modules (#3026) --- backend/.ocamlformat-enable | 5 ++ backend/amd64/cfg_selection.ml | 26 ++++++ backend/arm64/cfg_selection.ml | 28 +++++++ backend/asmgen.ml | 133 +++++++++++++++++++------------ backend/cfg_selectgen.ml | 21 +++++ backend/cfg_selectgen.mli | 21 +++++ backend/cfg_selection.mli | 22 +++++ backend/dune | 5 +- driver/flambda_backend_args.ml | 16 ++++ driver/flambda_backend_args.mli | 3 + driver/flambda_backend_flags.ml | 2 + driver/flambda_backend_flags.mli | 2 + dune | 2 + 13 files changed, 232 insertions(+), 54 deletions(-) create mode 100644 backend/amd64/cfg_selection.ml create mode 100644 backend/arm64/cfg_selection.ml create mode 100644 backend/cfg_selectgen.ml create mode 100644 backend/cfg_selectgen.mli create mode 100644 backend/cfg_selection.mli diff --git a/backend/.ocamlformat-enable b/backend/.ocamlformat-enable index e7691489d5e..af97d1dee68 100644 --- a/backend/.ocamlformat-enable +++ b/backend/.ocamlformat-enable @@ -1,7 +1,9 @@ +amd64/cfg_selection.ml amd64/selection.ml amd64/selection_utils.ml amd64/simd*.ml amd64/stack_check.ml +arm64/cfg_selection.ml arm64/selection.ml arm64/selection_utils.ml arm64/simd*.ml @@ -12,6 +14,9 @@ asmgen.ml asmgen.mli cfg/**/*.ml cfg/**/*.mli +cfg_selectgen.ml +cfg_selectgen.mli +cfg_selection.mli cmm_builtins.ml cmm_builtins.mli cmm_helpers.ml diff --git a/backend/amd64/cfg_selection.ml b/backend/amd64/cfg_selection.ml new file mode 100644 index 00000000000..c862a8ddaa5 --- /dev/null +++ b/backend/amd64/cfg_selection.ml @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Instruction selection for the AMD64 *) + +[@@@ocaml.warning "+a-4-9-40-41-42"] + +let fundecl ~future_funcnames:_ _ = + let _ = + object + inherit Cfg_selectgen.selector_generic + end + in + Misc.fatal_error "Cfg_selection.fundecl: not implemented" diff --git a/backend/arm64/cfg_selection.ml b/backend/arm64/cfg_selection.ml new file mode 100644 index 00000000000..8c6a1cac07a --- /dev/null +++ b/backend/arm64/cfg_selection.ml @@ -0,0 +1,28 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* Benedikt Meurer, University of Siegen *) +(* *) +(* Copyright 2013 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2012 Benedikt Meurer. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Instruction selection for the ARM processor *) + +[@@@ocaml.warning "+a-4-9-40-41-42"] + +let fundecl ~future_funcnames:_ _ = + let _ = + object + inherit Cfg_selectgen.selector_generic + end + in + Misc.fatal_error "Cfg_selection.fundecl: not implemented" diff --git a/backend/asmgen.ml b/backend/asmgen.ml index 9234f3712bc..d62a15a968e 100644 --- a/backend/asmgen.ml +++ b/backend/asmgen.ml @@ -352,66 +352,88 @@ let register_allocator fd : register_allocator = let is_upstream = function Upstream -> true | GI | IRC | LS -> false +type selection_output = + | Mach_fundecl of Mach.fundecl + | Cfg_with_layout of Cfg_with_layout.t + let compile_fundecl ~ppf_dump ~funcnames fd_cmm = Proc.init (); Reg.reset (); let register_allocator = register_allocator fd_cmm in fd_cmm ++ Profile.record ~accumulate:true "cmm_invariants" (cmm_invariants ppf_dump) - ++ Profile.record ~accumulate:true "selection" - (Selection.fundecl ~future_funcnames:funcnames) - ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_sel - ++ pass_dump_if ppf_dump dump_selection "After instruction selection" - ++ Profile.record ~accumulate:true "save_mach_as_cfg" - (save_mach_as_cfg Compiler_pass.Selection) - ++ Profile.record ~accumulate:true "polling" (fun fd -> - match register_allocator with - | IRC | LS | GI -> fd - | Upstream -> Polling.instrument_fundecl ~future_funcnames:funcnames fd) - ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_polling - ++ (fun fd -> - match !Flambda_backend_flags.cfg_zero_alloc_checker with + ++ (fun (fd_cmm : Cmm.fundecl) -> + match !Flambda_backend_flags.cfg_selection with | false -> - fd - ++ Profile.record ~accumulate:true "zero_alloc_checker" - (Zero_alloc_checker.fundecl ~future_funcnames:funcnames ppf_dump) + ( ( fd_cmm + ++ Profile.record ~accumulate:true "selection" + (Selection.fundecl ~future_funcnames:funcnames) + ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_sel + ++ pass_dump_if ppf_dump dump_selection "After instruction selection" + ++ Profile.record ~accumulate:true "save_mach_as_cfg" + (save_mach_as_cfg Compiler_pass.Selection) + ++ Profile.record ~accumulate:true "polling" (fun fd -> + match register_allocator with + | IRC | LS | GI -> fd + | Upstream -> + Polling.instrument_fundecl ~future_funcnames:funcnames fd) + ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_polling + ++ fun fd -> + match !Flambda_backend_flags.cfg_zero_alloc_checker with + | false -> + fd + ++ Profile.record ~accumulate:true "zero_alloc_checker" + (Zero_alloc_checker.fundecl ~future_funcnames:funcnames + ppf_dump) + | true -> + (* Will happen after `Cfgize`. *) + if is_upstream register_allocator + then + fatal_error + "-cfg-zero-alloc-checker should only be used with a CFG \ + register allocator"; + fd ) + ++ fun fd -> + match !Flambda_backend_flags.cfg_cse_optimize with + | false -> + fd + ++ pass_dump_if ppf_dump dump_combine "Before allocation combining" + ++ Profile.record ~accumulate:true "comballoc" Comballoc.fundecl + ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_combine + ++ pass_dump_if ppf_dump dump_combine "After allocation combining" + ++ Profile.record ~accumulate:true "cse" CSE.fundecl + ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_cse + ++ pass_dump_if ppf_dump dump_cse "After CSE" + | true -> + (* Will happen after `Cfgize`. *) + if is_upstream register_allocator + then + fatal_error + "-cfg-cse-optimize should only be used with a CFG register \ + allocator"; + fd ) + ++ fun fd -> Mach_fundecl fd | true -> - (* Will happen after `Cfgize`. *) - if is_upstream register_allocator - then - fatal_error - "-cfg-zero-alloc-checker should only be used with a CFG register \ - allocator"; - fd) - ++ (fun fd -> - match !Flambda_backend_flags.cfg_cse_optimize with - | false -> - fd - ++ pass_dump_if ppf_dump dump_combine "Before allocation combining" - ++ Profile.record ~accumulate:true "comballoc" Comballoc.fundecl - ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_combine - ++ pass_dump_if ppf_dump dump_combine "After allocation combining" - ++ Profile.record ~accumulate:true "cse" CSE.fundecl - ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_cse - ++ pass_dump_if ppf_dump dump_cse "After CSE" - | true -> - (* Will happen after `Cfgize`. *) - if is_upstream register_allocator - then - fatal_error - "-cfg-cse-optimize should only be used with a CFG register \ - allocator"; - fd) - ++ Profile.record ~accumulate:true "regalloc" (fun (fd : Mach.fundecl) -> + Cfg_with_layout + (Cfg_selection.fundecl ~future_funcnames:funcnames fd_cmm + ++ pass_dump_cfg_if ppf_dump Flambda_backend_flags.dump_cfg + "After selection")) + ++ Profile.record ~accumulate:true "regalloc" (fun (fd : selection_output) -> match register_allocator with | (GI | IRC | LS) as regalloc -> - fd - ++ Profile.record ~accumulate:true "cfg" (fun fd -> - let cfg = - fd - ++ cfg_with_layout_profile ~accumulate:true "cfgize" cfgize - ++ pass_dump_cfg_if ppf_dump Flambda_backend_flags.dump_cfg - "After cfgize" + let cfg_with_layout = + match fd with + | Mach_fundecl fd -> + fd + ++ cfg_with_layout_profile ~accumulate:true "cfgize" cfgize + ++ pass_dump_cfg_if ppf_dump Flambda_backend_flags.dump_cfg + "After cfgize" + | Cfg_with_layout cfg_with_layout -> cfg_with_layout + in + cfg_with_layout + ++ Profile.record ~accumulate:true "cfg" (fun cfg_with_layout -> + let cfg_with_infos = + cfg_with_layout ++ (fun cfg_with_layout -> match !Flambda_backend_flags.vectorize with | false -> cfg_with_layout @@ -454,9 +476,9 @@ let compile_fundecl ~ppf_dump ~funcnames fd_cmm = in let cfg_description = Regalloc_validate.Description.create - (Cfg_with_infos.cfg_with_layout cfg) + (Cfg_with_infos.cfg_with_layout cfg_with_infos) in - cfg + cfg_with_infos ++ (match regalloc with | GI -> cfg_with_infos_profile ~accumulate:true "cfg_gi" @@ -494,6 +516,13 @@ let compile_fundecl ~ppf_dump ~funcnames fd_cmm = ++ Profile.record ~accumulate:true "cfg_to_linear" Cfg_to_linear.run) | Upstream -> + let fd = + match fd with + | Mach_fundecl fd -> fd + | Cfg_with_layout _ -> + Misc.fatal_error + "-cfg-selection cannot be used with the upstream allocators" + in fd ++ Profile.record ~accumulate:true "default" (fun fd -> fd diff --git a/backend/cfg_selectgen.ml b/backend/cfg_selectgen.ml new file mode 100644 index 00000000000..a69e3b62bac --- /dev/null +++ b/backend/cfg_selectgen.ml @@ -0,0 +1,21 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Selection of pseudo-instructions, assignment of pseudo-registers, + sequentialization. *) + +[@@@ocaml.warning "+a-4-9-40-41-42"] + +class virtual selector_generic = object end diff --git a/backend/cfg_selectgen.mli b/backend/cfg_selectgen.mli new file mode 100644 index 00000000000..1991c7275d1 --- /dev/null +++ b/backend/cfg_selectgen.mli @@ -0,0 +1,21 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Selection of pseudo-instructions, assignment of pseudo-registers, + sequentialization. *) + +[@@@ocaml.warning "+a-4-9-40-41-42"] + +class virtual selector_generic : object end diff --git a/backend/cfg_selection.mli b/backend/cfg_selection.mli new file mode 100644 index 00000000000..f720b3f512e --- /dev/null +++ b/backend/cfg_selection.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Selection of pseudo-instructions, assignment of pseudo-registers, + sequentialization. *) + +[@@@ocaml.warning "+a-4-9-40-41-42"] + +val fundecl : + future_funcnames:Misc.Stdlib.String.Set.t -> Cmm.fundecl -> Cfg_with_layout.t diff --git a/backend/dune b/backend/dune index c00bc9a5ac0..1af84238a6c 100644 --- a/backend/dune +++ b/backend/dune @@ -13,8 +13,9 @@ ;************************************************************************** (rule - (targets arch.ml arch.mli CSE.ml proc.ml regalloc_stack_operands.ml reload.ml selection.ml - selection_utils.ml simd.ml simd_selection.ml simd_reload.ml simd_proc.ml stack_check.ml) + (targets arch.ml arch.mli cfg_selection.ml CSE.ml proc.ml regalloc_stack_operands.ml reload.ml + selection.ml selection_utils.ml simd.ml simd_selection.ml simd_reload.ml simd_proc.ml + stack_check.ml) (mode fallback) (deps (glob_files amd64/*.ml) (glob_files amd64/*.mli) diff --git a/driver/flambda_backend_args.ml b/driver/flambda_backend_args.ml index 6620e0e7a29..c2d88d1644f 100644 --- a/driver/flambda_backend_args.ml +++ b/driver/flambda_backend_args.ml @@ -61,6 +61,12 @@ let mk_dvectorize f = "-dvectorize", Arg.Unit f, " (undocumented)" ;; +let mk_cfg_selection f = + "-cfg-selection", Arg.Unit f, " Produce CFG at selection" + +let mk_no_cfg_selection f = + "-no-cfg-selection", Arg.Unit f, " Do not produce CFG at selection" + let mk_cfg_peephole_optimize f = "-cfg-peephole-optimize", Arg.Unit f, " Apply peephole optimizations to CFG" @@ -677,6 +683,9 @@ module type Flambda_backend_options = sig val no_vectorize : unit -> unit val dvectorize : unit -> unit + val cfg_selection : unit -> unit + val no_cfg_selection : unit -> unit + val cfg_peephole_optimize : unit -> unit val no_cfg_peephole_optimize : unit -> unit @@ -804,6 +813,9 @@ struct mk_no_vectorize F.no_vectorize; mk_dvectorize F.dvectorize; + mk_cfg_selection F.cfg_selection; + mk_no_cfg_selection F.no_cfg_selection; + mk_cfg_peephole_optimize F.cfg_peephole_optimize; mk_no_cfg_peephole_optimize F.no_cfg_peephole_optimize; @@ -961,6 +973,9 @@ module Flambda_backend_options_impl = struct let no_vectorize = clear' Flambda_backend_flags.vectorize let dvectorize = set' Flambda_backend_flags.dump_vectorize + let cfg_selection = set' Flambda_backend_flags.cfg_selection + let no_cfg_selection = clear' Flambda_backend_flags.cfg_selection + let cfg_peephole_optimize = set' Flambda_backend_flags.cfg_peephole_optimize let no_cfg_peephole_optimize = clear' Flambda_backend_flags.cfg_peephole_optimize @@ -1282,6 +1297,7 @@ module Extra_params = struct | "regalloc-param" -> add_string Flambda_backend_flags.regalloc_params | "regalloc-validate" -> set' Flambda_backend_flags.regalloc_validate | "vectorize" -> set' Flambda_backend_flags.vectorize + | "cfg-selection" -> set' Flambda_backend_flags.cfg_selection | "cfg-peephole-optimize" -> set' Flambda_backend_flags.cfg_peephole_optimize | "cfg-cse-optimize" -> set' Flambda_backend_flags.cfg_cse_optimize | "cfg-zero-alloc-checker" -> set' Flambda_backend_flags.cfg_zero_alloc_checker diff --git a/driver/flambda_backend_args.mli b/driver/flambda_backend_args.mli index 44d4b9aab03..96288f4690c 100644 --- a/driver/flambda_backend_args.mli +++ b/driver/flambda_backend_args.mli @@ -38,6 +38,9 @@ module type Flambda_backend_options = sig val no_vectorize : unit -> unit val dvectorize : unit -> unit + val cfg_selection : unit -> unit + val no_cfg_selection : unit -> unit + val cfg_peephole_optimize : unit -> unit val no_cfg_peephole_optimize : unit -> unit diff --git a/driver/flambda_backend_flags.ml b/driver/flambda_backend_flags.ml index 07d5296a417..20c38a8b7f5 100644 --- a/driver/flambda_backend_flags.ml +++ b/driver/flambda_backend_flags.ml @@ -24,6 +24,8 @@ let regalloc_validate = ref true (* -[no-]regalloc-validate *) let vectorize = ref false (* -[no-]vectorize *) let dump_vectorize = ref false (* -dvectorize *) +let cfg_selection = ref false (* -[no-]cfg-selection *) + let cfg_peephole_optimize = ref true (* -[no-]cfg-peephole-optimize *) let cfg_cse_optimize = ref false (* -[no-]cfg-cse-optimize *) diff --git a/driver/flambda_backend_flags.mli b/driver/flambda_backend_flags.mli index eea5c961e52..ef604205431 100644 --- a/driver/flambda_backend_flags.mli +++ b/driver/flambda_backend_flags.mli @@ -25,6 +25,8 @@ val regalloc_validate : bool ref val vectorize : bool ref val dump_vectorize : bool ref +val cfg_selection : bool ref + val cfg_peephole_optimize: bool ref val cfg_cse_optimize: bool ref diff --git a/dune b/dune index 1eb2acec52f..73ddbe95e5f 100755 --- a/dune +++ b/dune @@ -91,6 +91,8 @@ asmpackager branch_relaxation branch_relaxation_intf + cfg_selectgen + cfg_selection cfgize cmm_helpers cmm_builtins From 7930fee5767d1ef98654f934cc5e0cd23e9b522d Mon Sep 17 00:00:00 2001 From: Xavier Clerc Date: Wed, 18 Sep 2024 12:23:07 +0100 Subject: [PATCH 55/76] Selection: CFG basics (#3030) --- backend/amd64/cfg_selection.ml | 13 +- backend/arm64/cfg_selection.ml | 13 +- backend/cfg_selectgen.ml | 350 ++++++++++++++++++++++++++++++++- backend/cfg_selectgen.mli | 275 +++++++++++++++++++++++++- 4 files changed, 635 insertions(+), 16 deletions(-) diff --git a/backend/amd64/cfg_selection.ml b/backend/amd64/cfg_selection.ml index c862a8ddaa5..ecf67760cc0 100644 --- a/backend/amd64/cfg_selection.ml +++ b/backend/amd64/cfg_selection.ml @@ -17,10 +17,9 @@ [@@@ocaml.warning "+a-4-9-40-41-42"] -let fundecl ~future_funcnames:_ _ = - let _ = - object - inherit Cfg_selectgen.selector_generic - end - in - Misc.fatal_error "Cfg_selection.fundecl: not implemented" +class virtual _selector = + object + inherit Cfg_selectgen.selector_generic + end + +let fundecl ~future_funcnames:_ _ = Misc.fatal_error "not implemented" diff --git a/backend/arm64/cfg_selection.ml b/backend/arm64/cfg_selection.ml index 8c6a1cac07a..e40beb5d9e9 100644 --- a/backend/arm64/cfg_selection.ml +++ b/backend/arm64/cfg_selection.ml @@ -19,10 +19,9 @@ [@@@ocaml.warning "+a-4-9-40-41-42"] -let fundecl ~future_funcnames:_ _ = - let _ = - object - inherit Cfg_selectgen.selector_generic - end - in - Misc.fatal_error "Cfg_selection.fundecl: not implemented" +class virtual _selector = + object + inherit Cfg_selectgen.selector_generic + end + +let fundecl ~future_funcnames:_ _ = Misc.fatal_error "not implemented" diff --git a/backend/cfg_selectgen.ml b/backend/cfg_selectgen.ml index a69e3b62bac..aca3f7551d9 100644 --- a/backend/cfg_selectgen.ml +++ b/backend/cfg_selectgen.ml @@ -18,4 +18,352 @@ [@@@ocaml.warning "+a-4-9-40-41-42"] -class virtual selector_generic = object end +open Cmm +open Select_utils + +type environment = unit Select_utils.environment + +type basic_or_terminator = + | Basic of Cfg.basic + | Terminator of Cfg.terminator + | With_next_label of (Label.t -> Cfg.terminator) + +let basic_op x = Basic (Op x) + +class virtual selector_generic = + object (self : 'self) + inherit [unit, Cfg.operation, Cfg.basic] Select_utils.common_selector + + method is_store op = match op with Store (_, _, _) -> true | _ -> false + + method lift_op op = Cfg.Op op + + method make_store mem_chunk addr_mode is_assignment = + Cfg.Op (Cfg.Store (mem_chunk, addr_mode, is_assignment)) + + method make_stack_offset stack_ofs = Cfg.Op (Stackoffset stack_ofs) + + method make_name_for_debugger ~ident ~which_parameter ~provenance + ~is_assignment ~regs = + Cfg.Op + (Cfg.Name_for_debugger + { ident; which_parameter; provenance; is_assignment; regs }) + + method make_const_int x = Cfg.Const_int x + + method make_const_float32 x = Cfg.Const_float32 x + + method make_const_float x = Cfg.Const_float x + + method make_const_vec128 x = Cfg.Const_vec128 x + + method make_const_symbol x = Cfg.Const_symbol x + + method make_opaque () = Cfg.Opaque + + (* Default instruction selection for stores (of words) *) + + method select_store is_assign addr arg : Cfg.operation * Cmm.expression = + Store (Word_val, addr, is_assign), arg + + (* Default instruction selection for operators *) + + method select_operation (op : Cmm.operation) (args : Cmm.expression list) + (_dbg : Debuginfo.t) : basic_or_terminator * Cmm.expression list = + match op, args with + | Capply _, Cconst_symbol (func, _dbg) :: rem -> + ( With_next_label + (fun label_after -> Call { op = Direct func; label_after }), + rem ) + | Capply _, _ -> + ( With_next_label + (fun label_after -> Call { op = Indirect; label_after }), + args ) + | Cextcall { func; builtin = true }, _ -> + Misc.fatal_errorf + "Selection.select_operation: builtin not recognized %s" func () + | Cextcall { func; alloc; ty; ty_args; returns; builtin = false }, _ -> + let external_call = + { Cfg.func_symbol = func; + alloc; + ty_res = ty; + ty_args; + stack_ofs = -1 + } + in + if returns + then + ( With_next_label + (fun label_after -> + Prim { op = External external_call; label_after }), + args ) + else Terminator (Call_no_return external_call), args + | Cload { memory_chunk; mutability; is_atomic }, [arg] -> + let addressing_mode, eloc = self#select_addressing memory_chunk arg in + let mutability = select_mutable_flag mutability in + ( basic_op + (Load { memory_chunk; addressing_mode; mutability; is_atomic }), + [eloc] ) + | Cstore (chunk, init), [arg1; arg2] -> + let addr, eloc = self#select_addressing chunk arg1 in + let is_assign = + match init with Initialization -> false | Assignment -> true + in + if chunk = Word_int || chunk = Word_val + then + let op, newarg2 = self#select_store is_assign addr arg2 in + basic_op op, [newarg2; eloc] + else basic_op (Store (chunk, addr, is_assign)), [arg2; eloc] + (* Inversion addr/datum in Istore *) + | Cdls_get, _ -> basic_op Dls_get, args + | Calloc mode, _ -> + basic_op (Alloc { bytes = 0; dbginfo = []; mode }), args + | Caddi, _ -> self#select_arith_comm Mach.Iadd args + | Csubi, _ -> self#select_arith Mach.Isub args + | Cmuli, _ -> self#select_arith_comm Mach.Imul args + | Cmulhi { signed }, _ -> + self#select_arith_comm (Mach.Imulh { signed }) args + | Cdivi, _ -> basic_op (Intop Mach.Idiv), args + | Cmodi, _ -> basic_op (Intop Mach.Imod), args + | Cand, _ -> self#select_arith_comm Mach.Iand args + | Cor, _ -> self#select_arith_comm Mach.Ior args + | Cxor, _ -> self#select_arith_comm Mach.Ixor args + | Clsl, _ -> self#select_arith Mach.Ilsl args + | Clsr, _ -> self#select_arith Mach.Ilsr args + | Casr, _ -> self#select_arith Mach.Iasr args + | Cclz { arg_is_non_zero }, _ -> + basic_op (Intop (Mach.Iclz { arg_is_non_zero })), args + | Cctz { arg_is_non_zero }, _ -> + basic_op (Intop (Mach.Ictz { arg_is_non_zero })), args + | Cpopcnt, _ -> basic_op (Intop Mach.Ipopcnt), args + | Ccmpi comp, _ -> self#select_arith_comp (Mach.Isigned comp) args + | Caddv, _ -> self#select_arith_comm Mach.Iadd args + | Cadda, _ -> self#select_arith_comm Mach.Iadd args + | Ccmpa comp, _ -> self#select_arith_comp (Mach.Iunsigned comp) args + | Ccmpf (w, comp), _ -> basic_op (Floatop (w, Mach.Icompf comp)), args + | Ccsel _, [cond; ifso; ifnot] -> + let cond, earg = self#select_condition cond in + basic_op (Csel cond), [earg; ifso; ifnot] + | Cnegf w, _ -> basic_op (Floatop (w, Mach.Inegf)), args + | Cabsf w, _ -> basic_op (Floatop (w, Mach.Iabsf)), args + | Caddf w, _ -> basic_op (Floatop (w, Mach.Iaddf)), args + | Csubf w, _ -> basic_op (Floatop (w, Mach.Isubf)), args + | Cmulf w, _ -> basic_op (Floatop (w, Mach.Imulf)), args + | Cdivf w, _ -> basic_op (Floatop (w, Mach.Idivf)), args + | Creinterpret_cast cast, _ -> basic_op (Reinterpret_cast cast), args + | Cstatic_cast cast, _ -> basic_op (Static_cast cast), args + | Catomic { op = Fetch_and_add; size }, [src; dst] -> + let dst_size = + match size with + | Word | Sixtyfour -> Word_int + | Thirtytwo -> Thirtytwo_signed + in + let addr, eloc = self#select_addressing dst_size dst in + basic_op (Intop_atomic { op = Fetch_and_add; size; addr }), [src; eloc] + | Catomic { op = Compare_and_swap; size }, [compare_with; set_to; dst] -> + let dst_size = + match size with + | Word | Sixtyfour -> Word_int + | Thirtytwo -> Thirtytwo_signed + in + let addr, eloc = self#select_addressing dst_size dst in + ( basic_op (Intop_atomic { op = Compare_and_swap; size; addr }), + [compare_with; set_to; eloc] ) + | Cprobe { name; handler_code_sym; enabled_at_init }, _ -> + ( With_next_label + (fun label_after -> + Prim + { op = Probe { name; handler_code_sym; enabled_at_init }; + label_after + }), + args ) + | Cprobe_is_enabled { name }, _ -> + basic_op (Probe_is_enabled { name }), [] + | Cbeginregion, _ -> basic_op Begin_region, [] + | Cendregion, _ -> basic_op End_region, args + | _ -> Misc.fatal_error "Selection.select_oper" + + method private select_arith_comm (op : Mach.integer_operation) + (args : Cmm.expression list) : basic_or_terminator * Cmm.expression list + = + match args with + | [arg; Cconst_int (n, _)] when self#is_immediate op n -> + basic_op (Intop_imm (op, n)), [arg] + | [Cconst_int (n, _); arg] when self#is_immediate op n -> + basic_op (Intop_imm (op, n)), [arg] + | _ -> basic_op (Intop op), args + + method private select_arith (op : Mach.integer_operation) + (args : Cmm.expression list) : basic_or_terminator * Cmm.expression list + = + match args with + | [arg; Cconst_int (n, _)] when self#is_immediate op n -> + basic_op (Intop_imm (op, n)), [arg] + | _ -> basic_op (Intop op), args + + method private select_arith_comp (cmp : Mach.integer_comparison) + (args : Cmm.expression list) : basic_or_terminator * Cmm.expression list + = + match args with + | [arg; Cconst_int (n, _)] when self#is_immediate (Mach.Icomp cmp) n -> + basic_op (Intop_imm (Icomp cmp, n)), [arg] + | [Cconst_int (n, _); arg] + when self#is_immediate (Mach.Icomp (Select_utils.swap_intcomp cmp)) n -> + basic_op (Intop_imm (Icomp (Select_utils.swap_intcomp cmp), n)), [arg] + | _ -> basic_op (Intop (Icomp cmp)), args + + (* Buffering of instruction sequences *) + + method insert + : environment -> Cfg.basic -> Reg.t array -> Reg.t array -> unit = + fun _ _ _ _ -> Misc.fatal_error "not implemented" + + method insert_debug + : environment -> + Cfg.basic -> + Debuginfo.t -> + Reg.t array -> + Reg.t array -> + unit = + fun _ _ _ _ _ -> Misc.fatal_error "not implemented" + + method insert_move env src dst = + if src.Reg.stamp <> dst.Reg.stamp + then self#insert env Cfg.(Op Move) [| src |] [| dst |] + + method emit_expr_aux_raise + : environment -> + Lambda.raise_kind -> + Cmm.expression -> + Debuginfo.t -> + Reg.t array option = + fun _ _ _ _ -> Misc.fatal_error "not implemented" + + method emit_expr_aux_op + : environment -> + Backend_var.With_provenance.t option -> + Cmm.operation -> + Cmm.expression list -> + Debuginfo.t -> + Reg.t array option = + fun _ _ _ _ _ -> Misc.fatal_error "not implemented" + + method emit_expr_aux_ifthenelse + : environment -> + Backend_var.With_provenance.t option -> + Cmm.expression -> + Debuginfo.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + Reg.t array option = + fun _ _ _ _ _ _ _ _ _ -> Misc.fatal_error "not implemented" + + method emit_expr_aux_switch + : environment -> + Backend_var.With_provenance.t option -> + Cmm.expression -> + int array -> + (Cmm.expression * Debuginfo.t) array -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + Reg.t array option = + fun _ _ _ _ _ _ _ -> Misc.fatal_error "not implemented" + + method emit_expr_aux_catch + : environment -> + Backend_var.With_provenance.t option -> + Cmm.rec_flag -> + (Lambda.static_label + * (Backend_var.With_provenance.t * Cmm.machtype) list + * Cmm.expression + * Debuginfo.t + * bool) + list -> + Cmm.expression -> + Cmm.kind_for_unboxing -> + Reg.t array option = + fun _ _ _ _ _ -> Misc.fatal_error "not implemented" + + method emit_expr_aux_exit + : environment -> + Cmm.exit_label -> + Cmm.expression list -> + Cmm.trap_action list -> + Reg.t array option = + fun _ _ _ _ -> Misc.fatal_error "not implemented" + + method emit_expr_aux_trywith + : environment -> + Backend_var.With_provenance.t option -> + Cmm.expression -> + Cmm.trywith_shared_label -> + Backend_var.With_provenance.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + Reg.t array option = + fun _ _ _ _ _ _ _ _ -> Misc.fatal_error "not implemented" + + method emit_return + : environment -> Cmm.expression -> Cmm.trap_action list -> unit = + fun _ _ _ -> Misc.fatal_error "not implemented" + + method emit_tail_apply + : environment -> + Cmm.machtype -> + Cmm.operation -> + Cmm.expression list -> + Debuginfo.t -> + unit = + fun _ _ _ _ _ -> Misc.fatal_error "not implemented" + + method emit_tail_ifthenelse + : environment -> + Cmm.expression -> + Debuginfo.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + unit = + fun _ _ _ _ _ _ _ _ -> Misc.fatal_error "not implemented" + + method emit_tail_switch + : environment -> + Cmm.expression -> + int array -> + (Cmm.expression * Debuginfo.t) array -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + unit = + fun _ _ _ _ _ _ -> Misc.fatal_error "not implemented" + + method emit_tail_catch + : environment -> + Cmm.rec_flag -> + (Lambda.static_label + * (Backend_var.With_provenance.t * Cmm.machtype) list + * Cmm.expression + * Debuginfo.t + * bool) + list -> + Cmm.expression -> + Cmm.kind_for_unboxing -> + unit = + fun _ _ _ _ _ -> Misc.fatal_error "not implemented" + + method emit_tail_trywith + : environment -> + Cmm.expression -> + Cmm.trywith_shared_label -> + Backend_var.With_provenance.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + unit = + fun _ _ _ _ _ _ _ -> Misc.fatal_error "not implemented" + end diff --git a/backend/cfg_selectgen.mli b/backend/cfg_selectgen.mli index 1991c7275d1..6fdc7353770 100644 --- a/backend/cfg_selectgen.mli +++ b/backend/cfg_selectgen.mli @@ -18,4 +18,277 @@ [@@@ocaml.warning "+a-4-9-40-41-42"] -class virtual selector_generic : object end +type environment = unit Select_utils.environment + +type basic_or_terminator = + | Basic of Cfg.basic + | Terminator of Cfg.terminator + | With_next_label of (Label.t -> Cfg.terminator) + +class virtual selector_generic : + object + method is_store : Cfg.operation -> bool + + method lift_op : Cfg.operation -> Cfg.basic + + method make_store : + Cmm.memory_chunk -> Arch.addressing_mode -> bool -> Cfg.basic + + method make_stack_offset : int -> Cfg.basic + + method make_name_for_debugger : + ident:Backend_var.t -> + which_parameter:int option -> + provenance:Backend_var.Provenance.t option -> + is_assignment:bool -> + regs:Reg.t array -> + Cfg.basic + + method make_const_int : nativeint -> Cfg.operation + + method make_const_float32 : int32 -> Cfg.operation + + method make_const_float : int64 -> Cfg.operation + + method make_const_vec128 : Cmm.vec128_bits -> Cfg.operation + + method make_const_symbol : Cmm.symbol -> Cfg.operation + + method make_opaque : unit -> Cfg.operation + + (* The following methods must or can be overridden by the processor + description *) + method is_immediate : Mach.integer_operation -> int -> bool + (* Must be overriden to indicate whether a constant is a suitable immediate + operand to the given integer arithmetic instruction. The default + implementation handles shifts by immediate amounts, but produces no + immediate operations otherwise. *) + + method virtual is_immediate_test : Mach.integer_comparison -> int -> bool + (* Must be defined to indicate whether a constant is a suitable immediate + operand to the given integer test *) + + method virtual select_addressing : + Cmm.memory_chunk -> + Cmm.expression -> + Arch.addressing_mode * Cmm.expression + (* Must be defined to select addressing modes *) + + method is_simple_expr : Cmm.expression -> bool + + method effects_of : Cmm.expression -> Select_utils.Effect_and_coeffect.t + (* Can be overridden to reflect special extcalls known to be pure *) + + method select_operation : + Cmm.operation -> + Cmm.expression list -> + Debuginfo.t -> + basic_or_terminator * Cmm.expression list + (* Can be overridden to deal with special arithmetic instructions *) + + method select_condition : Cmm.expression -> Mach.test * Cmm.expression + (* Can be overridden to deal with special test instructions *) + + method select_store : + bool -> + Arch.addressing_mode -> + Cmm.expression -> + Cfg.operation * Cmm.expression + (* Can be overridden to deal with special store constant instructions *) + + method regs_for : Cmm.machtype -> Reg.t array + (* Return an array of fresh registers of the given type. Default + implementation is like Reg.createv. Can be overridden if float values are + stored as pairs of integer registers. *) + + method insert_op : + environment -> Cfg.operation -> Reg.t array -> Reg.t array -> Reg.t array + (* Can be overridden to deal with 2-address instructions or instructions + with hardwired input/output registers *) + + method insert_op_debug : + environment -> + Cfg.operation -> + Debuginfo.t -> + Reg.t array -> + Reg.t array -> + Reg.t array + (* Can be overridden to deal with 2-address instructions or instructions + with hardwired input/output registers *) + + method insert_move_extcall_arg : + environment -> Cmm.exttype -> Reg.t array -> Reg.t array -> unit + (* Can be overridden to deal with unusual unboxed calling conventions, e.g. + on a 64-bit platform, passing unboxed 32-bit arguments in 32-bit stack + slots. *) + + method emit_extcall_args : + environment -> + Cmm.exttype list -> + Cmm.expression list -> + Reg.t array * int + (* Can be overridden to deal with stack-based calling conventions *) + + method emit_stores : + environment -> Debuginfo.t -> Cmm.expression list -> Reg.t array -> unit + (* Fill a freshly allocated block. Can be overridden for architectures that + do not provide Arch.offset_addressing. *) + + method insert : + environment -> Cfg.basic -> Reg.t array -> Reg.t array -> unit + + method insert_debug : + environment -> + Cfg.basic -> + Debuginfo.t -> + Reg.t array -> + Reg.t array -> + unit + + method insert_move : environment -> Reg.t -> Reg.t -> unit + + method insert_move_args : + environment -> Reg.t array -> Reg.t array -> int -> unit + + method insert_move_results : + environment -> Reg.t array -> Reg.t array -> int -> unit + + method insert_moves : environment -> Reg.t array -> Reg.t array -> unit + + method emit_expr : + environment -> + Cmm.expression -> + bound_name:Backend_var.With_provenance.t option -> + Reg.t array option + + method emit_expr_aux : + environment -> + Cmm.expression -> + bound_name:Backend_var.With_provenance.t option -> + Reg.t array option + + method emit_expr_aux_raise : + environment -> + Lambda.raise_kind -> + Cmm.expression -> + Debuginfo.t -> + Reg.t array option + + method emit_expr_aux_op : + environment -> + Backend_var.With_provenance.t option -> + Cmm.operation -> + Cmm.expression list -> + Debuginfo.t -> + Reg.t array option + + method emit_expr_aux_ifthenelse : + environment -> + Backend_var.With_provenance.t option -> + Cmm.expression -> + Debuginfo.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + Reg.t array option + + method emit_expr_aux_switch : + environment -> + Backend_var.With_provenance.t option -> + Cmm.expression -> + int array -> + (Cmm.expression * Debuginfo.t) array -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + Reg.t array option + + method emit_expr_aux_catch : + environment -> + Backend_var.With_provenance.t option -> + Cmm.rec_flag -> + (Lambda.static_label + * (Backend_var.With_provenance.t * Cmm.machtype) list + * Cmm.expression + * Debuginfo.t + * bool) + list -> + Cmm.expression -> + Cmm.kind_for_unboxing -> + Reg.t array option + + method emit_expr_aux_exit : + environment -> + Cmm.exit_label -> + Cmm.expression list -> + Cmm.trap_action list -> + Reg.t array option + + method emit_expr_aux_trywith : + environment -> + Backend_var.With_provenance.t option -> + Cmm.expression -> + Cmm.trywith_shared_label -> + Backend_var.With_provenance.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + Reg.t array option + + method emit_tail : environment -> Cmm.expression -> unit + + method emit_tail_apply : + environment -> + Cmm.machtype -> + Cmm.operation -> + Cmm.expression list -> + Debuginfo.t -> + unit + + method emit_tail_ifthenelse : + environment -> + Cmm.expression -> + Debuginfo.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + unit + + method emit_tail_switch : + environment -> + Cmm.expression -> + int array -> + (Cmm.expression * Debuginfo.t) array -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + unit + + method emit_tail_catch : + environment -> + Cmm.rec_flag -> + (Lambda.static_label + * (Backend_var.With_provenance.t * Cmm.machtype) list + * Cmm.expression + * Debuginfo.t + * bool) + list -> + Cmm.expression -> + Cmm.kind_for_unboxing -> + unit + + method emit_tail_trywith : + environment -> + Cmm.expression -> + Cmm.trywith_shared_label -> + Backend_var.With_provenance.t -> + Cmm.expression -> + Debuginfo.t -> + Cmm.kind_for_unboxing -> + unit + + method emit_return : + environment -> Cmm.expression -> Cmm.trap_action list -> unit + end From 64a86758e9567bcd86677fea45475be8bc7f6125 Mon Sep 17 00:00:00 2001 From: Xavier Clerc Date: Wed, 18 Sep 2024 13:02:57 +0100 Subject: [PATCH 56/76] Selection: architecture-dependent elements (CFG pipeline) (#3046) --- backend/amd64/cfg_selection.ml | 304 ++++++++++++++++++++++++++++++- backend/amd64/selection.ml | 85 +++++++++ backend/amd64/selection_utils.ml | 85 --------- backend/amd64/simd_selection.ml | 4 + backend/arm64/cfg_selection.ml | 151 ++++++++++++++- backend/cfg_selectgen.ml | 52 ++++-- backend/cfg_selectgen.mli | 5 + 7 files changed, 578 insertions(+), 108 deletions(-) diff --git a/backend/amd64/cfg_selection.ml b/backend/amd64/cfg_selection.ml index ecf67760cc0..1c30c4d07f2 100644 --- a/backend/amd64/cfg_selection.ml +++ b/backend/amd64/cfg_selection.ml @@ -17,9 +17,305 @@ [@@@ocaml.warning "+a-4-9-40-41-42"] -class virtual _selector = - object - inherit Cfg_selectgen.selector_generic +open Arch +open Selection_utils + +let specific x = Cfg_selectgen.Basic (Op (Specific x)) + +let pseudoregs_for_operation op arg res = + match (op : Cfg.operation) with + (* Two-address binary operations: arg.(0) and res.(0) must be the same *) + | Intop (Iadd | Isub | Imul | Iand | Ior | Ixor) + | Floatop ((Float32 | Float64), (Iaddf | Isubf | Imulf | Idivf)) -> + [| res.(0); arg.(1) |], res + | Intop_atomic { op = Compare_and_swap; size = _; addr = _ } -> + (* first arg must be rax *) + let arg = Array.copy arg in + arg.(0) <- rax; + arg, res + | Intop_atomic { op = Fetch_and_add; size = _; addr = _ } -> + (* first arg must be the same as res.(0) *) + let arg = Array.copy arg in + arg.(0) <- res.(0); + arg, res + (* One-address unary operations: arg.(0) and res.(0) must be the same *) + | Intop_imm ((Iadd | Isub | Imul | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr), _) + | Floatop ((Float64 | Float32), (Iabsf | Inegf)) + | Specific (Ibswap { bitwidth = Thirtytwo | Sixtyfour }) -> + res, res + (* For xchg, args must be a register allowing access to high 8 bit register + (rax, rbx, rcx or rdx). Keep it simple, just force the argument in rax. *) + | Specific (Ibswap { bitwidth = Sixteen }) -> [| rax |], [| rax |] + (* For imulh, first arg must be in rax, rax is clobbered, and result is in + rdx. *) + | Intop (Imulh _) -> [| rax; arg.(1) |], [| rdx |] + | Specific (Ifloatarithmem (_, _, _)) -> + let arg' = Array.copy arg in + arg'.(0) <- res.(0); + arg', res + (* For shifts with variable shift count, second arg must be in rcx *) + | Intop (Ilsl | Ilsr | Iasr) -> [| res.(0); rcx |], res + (* For div and mod, first arg must be in rax, rdx is clobbered, and result is + in rax or rdx respectively. Keep it simple, just force second argument in + rcx. *) + | Intop Idiv -> [| rax; rcx |], [| rax |] + | Intop Imod -> [| rax; rcx |], [| rdx |] + | Floatop (Float64, Icompf cond) -> + (* CR gyorsh: make this optimization as a separate PR. *) + (* We need to temporarily store the result of the comparison in a float + register, but we don't want to clobber any of the inputs if they would + still be live after this operation -- so we add a fresh register as both + an input and output. We don't use [destroyed_at_oper], because that + forces us to choose a fixed register, which makes it more likely an extra + mov would be added to transfer the argument to the fixed register. *) + let treg = Reg.create Float in + let _, is_swapped = float_cond_and_need_swap cond in + ( (if is_swapped then [| arg.(0); treg |] else [| treg; arg.(1) |]), + [| res.(0); treg |] ) + | Floatop (Float32, Icompf cond) -> + let treg = Reg.create Float32 in + let _, is_swapped = float_cond_and_need_swap cond in + ( (if is_swapped then [| arg.(0); treg |] else [| treg; arg.(1) |]), + [| res.(0); treg |] ) + | Specific Irdpmc -> + (* For rdpmc instruction, the argument must be in ecx and the result is in + edx (high) and eax (low). Make it simple and force the argument in rcx, + and rax and rdx clobbered *) + [| rcx |], res + | Specific (Isimd op) -> Simd_selection.pseudoregs_for_operation op arg res + | Csel _ -> + (* last arg must be the same as res.(0) *) + let len = Array.length arg in + let arg = Array.copy arg in + arg.(len - 1) <- res.(0); + arg, res + (* Other instructions are regular *) + | Intop (Ipopcnt | Iclz _ | Ictz _ | Icomp _) + | Intop_imm ((Imulh _ | Idiv | Imod | Icomp _ | Ipopcnt | Iclz _ | Ictz _), _) + | Specific + ( Isextend32 | Izextend32 | Ilea _ + | Istore_int (_, _, _) + | Ipause | Ilfence | Isfence | Imfence + | Ioffset_loc (_, _) + | Irdtsc | Iprefetch _ ) + | Move | Spill | Reload | Reinterpret_cast _ | Static_cast _ | Const_int _ + | Const_float32 _ | Const_float _ | Const_vec128 _ | Const_symbol _ + | Stackoffset _ | Load _ + | Store (_, _, _) + | Alloc _ | Name_for_debugger _ | Probe_is_enabled _ | Opaque | Begin_region + | End_region | Poll | Dls_get -> + raise Use_default + +(* The selector class *) + +class selector = + object (self) + inherit Cfg_selectgen.selector_generic as super + + method! is_immediate op n = + match op with + | Iadd | Isub | Imul | Iand | Ior | Ixor | Icomp _ -> is_immediate n + | _ -> super#is_immediate op n + + method is_immediate_test _cmp n = is_immediate n + + method! is_simple_expr e = + match e with + | Cop (Cextcall { func = fn }, args, _) when List.mem fn inline_ops -> + (* inlined ops are simple if their arguments are *) + List.for_all self#is_simple_expr args + | _ -> super#is_simple_expr e + + method! effects_of e = + match e with + | Cop (Cextcall { func = fn }, args, _) when List.mem fn inline_ops -> + Select_utils.Effect_and_coeffect.join_list_map args self#effects_of + | _ -> super#effects_of e + + method select_addressing _chunk exp = + let a, d = select_addr exp in + (* PR#4625: displacement must be a signed 32-bit immediate *) + if not (is_immediate d) + then Iindexed 0, exp + else + match a with + | Asymbol s -> + let glob : Arch.sym_global = + match s.sym_global with Global -> Global | Local -> Local + in + Ibased (s.sym_name, glob, d), Ctuple [] + | Alinear e -> Iindexed d, e + | Aadd (e1, e2) -> Iindexed2 d, Ctuple [e1; e2] + | Ascale (e, scale) -> Iscaled (scale, d), e + | Ascaledadd (e1, e2, scale) -> + Iindexed2scaled (scale, d), Ctuple [e1; e2] + + method! select_store is_assign addr exp = + match exp with + | Cconst_int (n, _dbg) when is_immediate n -> + Specific (Istore_int (Nativeint.of_int n, addr, is_assign)), Ctuple [] + | Cconst_natint (n, _dbg) when is_immediate_natint n -> + Specific (Istore_int (n, addr, is_assign)), Ctuple [] + | Cconst_int _ | Cconst_vec128 _ + | Cconst_natint (_, _) + | Cconst_float32 (_, _) + | Cconst_float (_, _) + | Cconst_symbol (_, _) + | Cvar _ + | Clet (_, _, _) + | Clet_mut (_, _, _, _) + | Cphantom_let (_, _, _) + | Cassign (_, _) + | Ctuple _ + | Cop (_, _, _) + | Csequence (_, _) + | Cifthenelse (_, _, _, _, _, _, _) + | Cswitch (_, _, _, _, _) + | Ccatch (_, _, _, _) + | Cexit (_, _, _) + | Ctrywith (_, _, _, _, _, _) -> + super#select_store is_assign addr exp + + method! select_operation op args dbg = + match op with + (* Recognize the LEA instruction *) + | Caddi | Caddv | Cadda | Csubi -> ( + match self#select_addressing Word_int (Cop (op, args, dbg)) with + | Iindexed _, _ | Iindexed2 0, _ -> super#select_operation op args dbg + | ( ((Iindexed2 _ | Iscaled _ | Iindexed2scaled _ | Ibased _) as addr), + arg ) -> + specific (Ilea addr), [arg]) + (* Recognize float arithmetic with memory. *) + | Caddf width -> + self#select_floatarith true width Mach.Iaddf Arch.Ifloatadd args + | Csubf width -> + self#select_floatarith false width Mach.Isubf Arch.Ifloatsub args + | Cmulf width -> + self#select_floatarith true width Mach.Imulf Arch.Ifloatmul args + | Cdivf width -> + self#select_floatarith false width Mach.Idivf Arch.Ifloatdiv args + | Cpackf32 -> + (* We must operate on registers. This is because if the second argument + was a float stack slot, the resulting UNPCKLPS instruction would + enforce the validity of loading it as a 128-bit memory location, even + though it only loads 64 bits. *) + specific (Isimd (SSE Interleave_low_32_regs)), args + (* Special cases overriding C implementations (regardless of + [@@builtin]). *) + | Cextcall { func = "sqrt" as func; _ } + (* x86 intrinsics ([@@builtin]) *) + | Cextcall { func; builtin = true; _ } -> ( + match func with + | "caml_rdtsc_unboxed" -> specific Irdtsc, args + | "caml_rdpmc_unboxed" -> specific Irdpmc, args + | "caml_pause_hint" -> specific Ipause, args + | "caml_load_fence" -> specific Ilfence, args + | "caml_store_fence" -> specific Isfence, args + | "caml_memory_fence" -> specific Imfence, args + | _ -> ( + match Simd_selection.select_operation_cfg func args with + | Some (op, args) -> Basic (Op op), args + | None -> super#select_operation op args dbg)) + (* Recognize store instructions *) + | Cstore (((Word_int | Word_val) as chunk), _init) -> ( + match args with + | [loc; Cop (Caddi, [Cop (Cload _, [loc'], _); Cconst_int (n, _dbg)], _)] + when loc = loc' && is_immediate n -> + let addr, arg = self#select_addressing chunk loc in + specific (Ioffset_loc (n, addr)), [arg] + | _ -> super#select_operation op args dbg) + | Cbswap { bitwidth } -> + let bitwidth = select_bitwidth bitwidth in + specific (Ibswap { bitwidth }), args + (* Recognize sign extension *) + | Casr -> ( + match args with + | [Cop (Clsl, [k; Cconst_int (32, _)], _); Cconst_int (32, _)] -> + specific Isextend32, [k] + | _ -> super#select_operation op args dbg) + (* Recognize zero extension *) + | Cand -> ( + match args with + | [arg; Cconst_int (0xffff_ffff, _)] + | [arg; Cconst_natint (0xffff_ffffn, _)] + | [Cconst_int (0xffff_ffff, _); arg] + | [Cconst_natint (0xffff_ffffn, _); arg] -> + specific Izextend32, [arg] + | _ -> super#select_operation op args dbg) + | Ccsel _ -> ( + match args with + | [cond; ifso; ifnot] -> ( + let cond, earg = self#select_condition cond in + match cond with + | Ifloattest (w, CFeq) -> + (* CFeq cannot be represented as cmov without a jump. CFneq emits + cmov for "unordered" and "not equal" cases. Use Cneq and swap the + arguments. *) + Basic (Op (Csel (Ifloattest (w, CFneq)))), [earg; ifnot; ifso] + | _ -> Basic (Op (Csel cond)), [earg; ifso; ifnot]) + | _ -> super#select_operation op args dbg) + | Cprefetch { is_write; locality } -> + (* Emit prefetch for read hint when prefetchw is not supported. Matches + the behavior of gcc's __builtin_prefetch *) + let is_write = + if is_write && not (Arch.Extension.enabled PREFETCHW) + then false + else is_write + in + let locality : Arch.prefetch_temporal_locality_hint = + match select_locality locality with + | Moderate when is_write && not (Arch.Extension.enabled PREFETCHWT1) + -> + High + | l -> l + in + let addr, eloc = + self#select_addressing Word_int (one_arg "prefetch" args) + in + specific (Iprefetch { is_write; addr; locality }), [eloc] + | _ -> super#select_operation op args dbg + + (* Recognize float arithmetic with mem *) + + method select_floatarith commutative width regular_op mem_op args + : Cfg_selectgen.basic_or_terminator * Cmm.expression list = + let open Cmm in + match width, args with + | ( Float64, + [arg1; Cop (Cload { memory_chunk = Double as chunk; _ }, [loc2], _)] ) + | ( Float32, + [ arg1; + Cop + ( Cload { memory_chunk = Single { reg = Float32 } as chunk; _ }, + [loc2], + _ ) ] ) -> + let addr, arg2 = self#select_addressing chunk loc2 in + specific (Ifloatarithmem (width, mem_op, addr)), [arg1; arg2] + | ( Float64, + [Cop (Cload { memory_chunk = Double as chunk; _ }, [loc1], _); arg2] ) + | ( Float32, + [ Cop + ( Cload { memory_chunk = Single { reg = Float32 } as chunk; _ }, + [loc1], + _ ); + arg2 ] ) + when commutative -> + let addr, arg1 = self#select_addressing chunk loc1 in + specific (Ifloatarithmem (width, mem_op, addr)), [arg2; arg1] + | _, [arg1; arg2] -> Basic (Op (Floatop (width, regular_op))), [arg1; arg2] + | _ -> assert false + + (* Deal with register constraints *) + + method! insert_op_debug env op dbg rs rd = + try + let rsrc, rdst = pseudoregs_for_operation op rs rd in + self#insert_moves env rs rsrc; + self#insert_debug env (Op op) dbg rsrc rdst; + self#insert_moves env rdst rd; + rd + with Use_default -> super#insert_op_debug env op dbg rs rd end -let fundecl ~future_funcnames:_ _ = Misc.fatal_error "not implemented" +let fundecl ~future_funcnames f = + (new selector)#emit_fundecl ~future_funcnames f diff --git a/backend/amd64/selection.ml b/backend/amd64/selection.ml index ae71a985ef8..d853b2139af 100644 --- a/backend/amd64/selection.ml +++ b/backend/amd64/selection.ml @@ -20,6 +20,91 @@ open Arch open Selection_utils +let pseudoregs_for_operation op arg res = + match (op : Mach.operation) with + (* Two-address binary operations: arg.(0) and res.(0) must be the same *) + | Iintop (Iadd | Isub | Imul | Iand | Ior | Ixor) + | Ifloatop ((Float32 | Float64), (Iaddf | Isubf | Imulf | Idivf)) -> + [| res.(0); arg.(1) |], res + | Iintop_atomic { op = Compare_and_swap; size = _; addr = _ } -> + (* first arg must be rax *) + let arg = Array.copy arg in + arg.(0) <- rax; + arg, res + | Iintop_atomic { op = Fetch_and_add; size = _; addr = _ } -> + (* first arg must be the same as res.(0) *) + let arg = Array.copy arg in + arg.(0) <- res.(0); + arg, res + (* One-address unary operations: arg.(0) and res.(0) must be the same *) + | Iintop_imm ((Iadd | Isub | Imul | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr), _) + | Ifloatop ((Float64 | Float32), (Iabsf | Inegf)) + | Ispecific (Ibswap { bitwidth = Thirtytwo | Sixtyfour }) -> + res, res + (* For xchg, args must be a register allowing access to high 8 bit register + (rax, rbx, rcx or rdx). Keep it simple, just force the argument in rax. *) + | Ispecific (Ibswap { bitwidth = Sixteen }) -> [| rax |], [| rax |] + (* For imulh, first arg must be in rax, rax is clobbered, and result is in + rdx. *) + | Iintop (Imulh _) -> [| rax; arg.(1) |], [| rdx |] + | Ispecific (Ifloatarithmem (_, _, _)) -> + let arg' = Array.copy arg in + arg'.(0) <- res.(0); + arg', res + (* For shifts with variable shift count, second arg must be in rcx *) + | Iintop (Ilsl | Ilsr | Iasr) -> [| res.(0); rcx |], res + (* For div and mod, first arg must be in rax, rdx is clobbered, and result is + in rax or rdx respectively. Keep it simple, just force second argument in + rcx. *) + | Iintop Idiv -> [| rax; rcx |], [| rax |] + | Iintop Imod -> [| rax; rcx |], [| rdx |] + | Ifloatop (Float64, Icompf cond) -> + (* CR gyorsh: make this optimization as a separate PR. *) + (* We need to temporarily store the result of the comparison in a float + register, but we don't want to clobber any of the inputs if they would + still be live after this operation -- so we add a fresh register as both + an input and output. We don't use [destroyed_at_oper], because that + forces us to choose a fixed register, which makes it more likely an extra + mov would be added to transfer the argument to the fixed register. *) + let treg = Reg.create Float in + let _, is_swapped = float_cond_and_need_swap cond in + ( (if is_swapped then [| arg.(0); treg |] else [| treg; arg.(1) |]), + [| res.(0); treg |] ) + | Ifloatop (Float32, Icompf cond) -> + let treg = Reg.create Float32 in + let _, is_swapped = float_cond_and_need_swap cond in + ( (if is_swapped then [| arg.(0); treg |] else [| treg; arg.(1) |]), + [| res.(0); treg |] ) + | Ispecific Irdpmc -> + (* For rdpmc instruction, the argument must be in ecx and the result is in + edx (high) and eax (low). Make it simple and force the argument in rcx, + and rax and rdx clobbered *) + [| rcx |], res + | Ispecific (Isimd op) -> Simd_selection.pseudoregs_for_operation op arg res + | Icsel _ -> + (* last arg must be the same as res.(0) *) + let len = Array.length arg in + let arg = Array.copy arg in + arg.(len - 1) <- res.(0); + arg, res + (* Other instructions are regular *) + | Iintop (Ipopcnt | Iclz _ | Ictz _ | Icomp _) + | Iintop_imm ((Imulh _ | Idiv | Imod | Icomp _ | Ipopcnt | Iclz _ | Ictz _), _) + | Ispecific + ( Isextend32 | Izextend32 | Ilea _ + | Istore_int (_, _, _) + | Ipause | Ilfence | Isfence | Imfence + | Ioffset_loc (_, _) + | Irdtsc | Iprefetch _ ) + | Imove | Ispill | Ireload | Ireinterpret_cast _ | Istatic_cast _ + | Iconst_int _ | Iconst_float32 _ | Iconst_float _ | Iconst_vec128 _ + | Iconst_symbol _ | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ + | Iextcall _ | Istackoffset _ | Iload _ + | Istore (_, _, _) + | Ialloc _ | Iname_for_debugger _ | Iprobe _ | Iprobe_is_enabled _ | Iopaque + | Ibeginregion | Iendregion | Ipoll _ | Idls_get -> + raise Use_default + (* The selector class *) class selector = diff --git a/backend/amd64/selection_utils.ml b/backend/amd64/selection_utils.ml index 19249cbe884..8845a3e9c3e 100644 --- a/backend/amd64/selection_utils.ml +++ b/backend/amd64/selection_utils.ml @@ -88,91 +88,6 @@ let rdx = phys_reg Int 4 let _xmm0v () = phys_reg Vec128 100 -let pseudoregs_for_operation op arg res = - match (op : Mach.operation) with - (* Two-address binary operations: arg.(0) and res.(0) must be the same *) - | Iintop (Iadd | Isub | Imul | Iand | Ior | Ixor) - | Ifloatop ((Float32 | Float64), (Iaddf | Isubf | Imulf | Idivf)) -> - [| res.(0); arg.(1) |], res - | Iintop_atomic { op = Compare_and_swap; size = _; addr = _ } -> - (* first arg must be rax *) - let arg = Array.copy arg in - arg.(0) <- rax; - arg, res - | Iintop_atomic { op = Fetch_and_add; size = _; addr = _ } -> - (* first arg must be the same as res.(0) *) - let arg = Array.copy arg in - arg.(0) <- res.(0); - arg, res - (* One-address unary operations: arg.(0) and res.(0) must be the same *) - | Iintop_imm ((Iadd | Isub | Imul | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr), _) - | Ifloatop ((Float64 | Float32), (Iabsf | Inegf)) - | Ispecific (Ibswap { bitwidth = Thirtytwo | Sixtyfour }) -> - res, res - (* For xchg, args must be a register allowing access to high 8 bit register - (rax, rbx, rcx or rdx). Keep it simple, just force the argument in rax. *) - | Ispecific (Ibswap { bitwidth = Sixteen }) -> [| rax |], [| rax |] - (* For imulh, first arg must be in rax, rax is clobbered, and result is in - rdx. *) - | Iintop (Imulh _) -> [| rax; arg.(1) |], [| rdx |] - | Ispecific (Ifloatarithmem (_, _, _)) -> - let arg' = Array.copy arg in - arg'.(0) <- res.(0); - arg', res - (* For shifts with variable shift count, second arg must be in rcx *) - | Iintop (Ilsl | Ilsr | Iasr) -> [| res.(0); rcx |], res - (* For div and mod, first arg must be in rax, rdx is clobbered, and result is - in rax or rdx respectively. Keep it simple, just force second argument in - rcx. *) - | Iintop Idiv -> [| rax; rcx |], [| rax |] - | Iintop Imod -> [| rax; rcx |], [| rdx |] - | Ifloatop (Float64, Icompf cond) -> - (* CR gyorsh: make this optimization as a separate PR. *) - (* We need to temporarily store the result of the comparison in a float - register, but we don't want to clobber any of the inputs if they would - still be live after this operation -- so we add a fresh register as both - an input and output. We don't use [destroyed_at_oper], because that - forces us to choose a fixed register, which makes it more likely an extra - mov would be added to transfer the argument to the fixed register. *) - let treg = Reg.create Float in - let _, is_swapped = float_cond_and_need_swap cond in - ( (if is_swapped then [| arg.(0); treg |] else [| treg; arg.(1) |]), - [| res.(0); treg |] ) - | Ifloatop (Float32, Icompf cond) -> - let treg = Reg.create Float32 in - let _, is_swapped = float_cond_and_need_swap cond in - ( (if is_swapped then [| arg.(0); treg |] else [| treg; arg.(1) |]), - [| res.(0); treg |] ) - | Ispecific Irdpmc -> - (* For rdpmc instruction, the argument must be in ecx and the result is in - edx (high) and eax (low). Make it simple and force the argument in rcx, - and rax and rdx clobbered *) - [| rcx |], res - | Ispecific (Isimd op) -> Simd_selection.pseudoregs_for_operation op arg res - | Icsel _ -> - (* last arg must be the same as res.(0) *) - let len = Array.length arg in - let arg = Array.copy arg in - arg.(len - 1) <- res.(0); - arg, res - (* Other instructions are regular *) - | Iintop (Ipopcnt | Iclz _ | Ictz _ | Icomp _) - | Iintop_imm ((Imulh _ | Idiv | Imod | Icomp _ | Ipopcnt | Iclz _ | Ictz _), _) - | Ispecific - ( Isextend32 | Izextend32 | Ilea _ - | Istore_int (_, _, _) - | Ipause | Ilfence | Isfence | Imfence - | Ioffset_loc (_, _) - | Irdtsc | Iprefetch _ ) - | Imove | Ispill | Ireload | Ireinterpret_cast _ | Istatic_cast _ - | Iconst_int _ | Iconst_float32 _ | Iconst_float _ | Iconst_vec128 _ - | Iconst_symbol _ | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ - | Iextcall _ | Istackoffset _ | Iload _ - | Istore (_, _, _) - | Ialloc _ | Iname_for_debugger _ | Iprobe _ | Iprobe_is_enabled _ | Iopaque - | Ibeginregion | Iendregion | Ipoll _ | Idls_get -> - raise Use_default - let select_locality (l : Cmm.prefetch_temporal_locality_hint) : Arch.prefetch_temporal_locality_hint = match l with diff --git a/backend/amd64/simd_selection.ml b/backend/amd64/simd_selection.ml index f6cf760eeca..44130edd44f 100644 --- a/backend/amd64/simd_selection.ml +++ b/backend/amd64/simd_selection.ml @@ -435,6 +435,10 @@ let select_operation op args = select_simd_instr op args |> Option.map (fun (op, args) -> Mach.(Ispecific (Isimd op), args)) +let select_operation_cfg op args = + select_simd_instr op args + |> Option.map (fun (op, args) -> Cfg.Specific (Isimd op), args) + let pseudoregs_for_operation op arg res = let rax = Proc.phys_reg Int 0 in let rcx = Proc.phys_reg Int 5 in diff --git a/backend/arm64/cfg_selection.ml b/backend/arm64/cfg_selection.ml index e40beb5d9e9..162857aef0a 100644 --- a/backend/arm64/cfg_selection.ml +++ b/backend/arm64/cfg_selection.ml @@ -19,9 +19,152 @@ [@@@ocaml.warning "+a-4-9-40-41-42"] -class virtual _selector = - object - inherit Cfg_selectgen.selector_generic +open Arch +open Cmm +open Selection_utils + +let specific x = Cfg_selectgen.Basic Cfg.(Op (Specific x)) + +class selector = + object (self) + inherit Cfg_selectgen.selector_generic as super + + method is_immediate_test _cmp n = is_immediate n + + method! is_immediate op n = + match op with + | Iadd | Isub -> n <= 0xFFF_FFF && n >= -0xFFF_FFF + | Iand | Ior | Ixor -> is_logical_immediate_int n + | Icomp _ -> is_immediate n + | _ -> super#is_immediate op n + + method! is_simple_expr = + function + (* inlined floating-point ops are simple if their arguments are *) + | Cop (Cextcall { func }, args, _) when List.mem func inline_ops -> + List.for_all self#is_simple_expr args + | e -> super#is_simple_expr e + + method! effects_of e = + match e with + | Cop (Cextcall { func }, args, _) when List.mem func inline_ops -> + Select_utils.Effect_and_coeffect.join_list_map args self#effects_of + | e -> super#effects_of e + + method select_addressing chunk = + function + | Cop ((Caddv | Cadda), [Cconst_symbol (s, _); Cconst_int (n, _)], _) + when use_direct_addressing s -> + Ibased (s.sym_name, n), Ctuple [] + | Cop ((Caddv | Cadda), [arg; Cconst_int (n, _)], _) + when is_offset chunk n -> + Iindexed n, arg + | Cop + ( ((Caddv | Cadda) as op), + [arg1; Cop (Caddi, [arg2; Cconst_int (n, _)], _)], + dbg ) + when is_offset chunk n -> + Iindexed n, Cop (op, [arg1; arg2], dbg) + | Cconst_symbol (s, _) when use_direct_addressing s -> + Ibased (s.sym_name, 0), Ctuple [] + | arg -> Iindexed 0, arg + + method! select_operation op args dbg = + match op with + (* Integer addition *) + | Caddi | Caddv | Cadda -> ( + match args with + (* Shift-add *) + | [arg1; Cop (Clsl, [arg2; Cconst_int (n, _)], _)] when n > 0 && n < 64 + -> + specific (Ishiftarith (Ishiftadd, n)), [arg1; arg2] + | [arg1; Cop (Casr, [arg2; Cconst_int (n, _)], _)] when n > 0 && n < 64 + -> + specific (Ishiftarith (Ishiftadd, -n)), [arg1; arg2] + | [Cop (Clsl, [arg1; Cconst_int (n, _)], _); arg2] when n > 0 && n < 64 + -> + specific (Ishiftarith (Ishiftadd, n)), [arg2; arg1] + | [Cop (Casr, [arg1; Cconst_int (n, _)], _); arg2] when n > 0 && n < 64 + -> + specific (Ishiftarith (Ishiftadd, -n)), [arg2; arg1] + (* Multiply-add *) + | [arg1; Cop (Cmuli, args2, dbg)] | [Cop (Cmuli, args2, dbg); arg1] -> ( + match self#select_operation Cmuli args2 dbg with + | Basic (Op (Intop_imm (Ilsl, l))), [arg3] -> + specific (Ishiftarith (Ishiftadd, l)), [arg1; arg3] + | Basic (Op (Intop Imul)), [arg3; arg4] -> + specific Imuladd, [arg3; arg4; arg1] + | _ -> super#select_operation op args dbg) + | _ -> super#select_operation op args dbg) + (* Integer subtraction *) + | Csubi -> ( + match args with + (* Shift-sub *) + | [arg1; Cop (Clsl, [arg2; Cconst_int (n, _)], _)] when n > 0 && n < 64 + -> + specific (Ishiftarith (Ishiftsub, n)), [arg1; arg2] + | [arg1; Cop (Casr, [arg2; Cconst_int (n, _)], _)] when n > 0 && n < 64 + -> + specific (Ishiftarith (Ishiftsub, -n)), [arg1; arg2] + (* Multiply-sub *) + | [arg1; Cop (Cmuli, args2, dbg)] -> ( + match self#select_operation Cmuli args2 dbg with + | Basic (Op (Intop_imm (Ilsl, l))), [arg3] -> + specific (Ishiftarith (Ishiftsub, l)), [arg1; arg3] + | Basic (Op (Intop Imul)), [arg3; arg4] -> + specific Imulsub, [arg3; arg4; arg1] + | _ -> super#select_operation op args dbg) + | _ -> super#select_operation op args dbg) + (* Recognize sign extension *) + | Casr -> ( + match args with + | [Cop (Clsl, [k; Cconst_int (n, _)], _); Cconst_int (n', _)] + when n' = n && 0 < n && n < 64 -> + specific (Isignext (64 - n)), [k] + | _ -> super#select_operation op args dbg) + (* Use trivial addressing mode for atomic loads *) + | Cload { memory_chunk; mutability; is_atomic = true } -> + ( Basic + (Op + (Load + { memory_chunk; + addressing_mode = Iindexed 0; + mutability = Select_utils.select_mutable_flag mutability; + is_atomic = true + })), + args ) + (* Recognize floating-point negate and multiply *) + | Cnegf Float64 -> ( + match args with + | [Cop (Cmulf Float64, args, _)] -> specific Inegmulf, args + | _ -> super#select_operation op args dbg) + (* Recognize floating-point multiply and add/sub *) + | Caddf Float64 -> ( + match args with + | [arg; Cop (Cmulf Float64, args, _)] + | [Cop (Cmulf Float64, args, _); arg] -> + specific Imuladdf, arg :: args + | _ -> super#select_operation op args dbg) + | Csubf Float64 -> ( + match args with + | [arg; Cop (Cmulf Float64, args, _)] -> specific Imulsubf, arg :: args + | [Cop (Cmulf Float64, args, _); arg] -> + specific Inegmulsubf, arg :: args + | _ -> super#select_operation op args dbg) + (* Recognize floating-point square root *) + | Cextcall { func = "sqrt" } -> specific Isqrtf, args + (* Recognize bswap instructions *) + | Cbswap { bitwidth } -> + let bitwidth = select_bitwidth bitwidth in + specific (Ibswap { bitwidth }), args + (* Other operations are regular *) + | _ -> super#select_operation op args dbg + + method! insert_move_extcall_arg env ty_arg src dst = + if macosx && ty_arg = XInt32 && is_stack_slot dst + then self#insert env (Op (Specific Imove32)) src dst + else self#insert_moves env src dst end -let fundecl ~future_funcnames:_ _ = Misc.fatal_error "not implemented" +let fundecl ~future_funcnames f = + (new selector)#emit_fundecl ~future_funcnames f diff --git a/backend/cfg_selectgen.ml b/backend/cfg_selectgen.ml index aca3f7551d9..a8decd41404 100644 --- a/backend/cfg_selectgen.ml +++ b/backend/cfg_selectgen.ml @@ -216,7 +216,7 @@ class virtual selector_generic = method insert : environment -> Cfg.basic -> Reg.t array -> Reg.t array -> unit = - fun _ _ _ _ -> Misc.fatal_error "not implemented" + fun _ _ _ _ -> Misc.fatal_error "not implemented (Cfg_selectgen#insert)" method insert_debug : environment -> @@ -225,7 +225,8 @@ class virtual selector_generic = Reg.t array -> Reg.t array -> unit = - fun _ _ _ _ _ -> Misc.fatal_error "not implemented" + fun _ _ _ _ _ -> + Misc.fatal_error "not implemented (Cfg_selectgen#insert_debug)" method insert_move env src dst = if src.Reg.stamp <> dst.Reg.stamp @@ -237,7 +238,8 @@ class virtual selector_generic = Cmm.expression -> Debuginfo.t -> Reg.t array option = - fun _ _ _ _ -> Misc.fatal_error "not implemented" + fun _ _ _ _ -> + Misc.fatal_error "not implemented (Cfg_selectgen#emit_expr_aux_raise)" method emit_expr_aux_op : environment -> @@ -246,7 +248,8 @@ class virtual selector_generic = Cmm.expression list -> Debuginfo.t -> Reg.t array option = - fun _ _ _ _ _ -> Misc.fatal_error "not implemented" + fun _ _ _ _ _ -> + Misc.fatal_error "not implemented (Cfg_selectgen#emit_expr_aux_op)" method emit_expr_aux_ifthenelse : environment -> @@ -259,7 +262,9 @@ class virtual selector_generic = Debuginfo.t -> Cmm.kind_for_unboxing -> Reg.t array option = - fun _ _ _ _ _ _ _ _ _ -> Misc.fatal_error "not implemented" + fun _ _ _ _ _ _ _ _ _ -> + Misc.fatal_error + "not implemented (Cfg_selectgen#emit_expr_aux_ifthenelse)" method emit_expr_aux_switch : environment -> @@ -270,7 +275,8 @@ class virtual selector_generic = Debuginfo.t -> Cmm.kind_for_unboxing -> Reg.t array option = - fun _ _ _ _ _ _ _ -> Misc.fatal_error "not implemented" + fun _ _ _ _ _ _ _ -> + Misc.fatal_error "not implemented (Cfg_selectgen#emit_expr_aux_switch)" method emit_expr_aux_catch : environment -> @@ -285,7 +291,8 @@ class virtual selector_generic = Cmm.expression -> Cmm.kind_for_unboxing -> Reg.t array option = - fun _ _ _ _ _ -> Misc.fatal_error "not implemented" + fun _ _ _ _ _ -> + Misc.fatal_error "not implemented (Cfg_selectgen#emit_expr_aux_catch)" method emit_expr_aux_exit : environment -> @@ -293,7 +300,8 @@ class virtual selector_generic = Cmm.expression list -> Cmm.trap_action list -> Reg.t array option = - fun _ _ _ _ -> Misc.fatal_error "not implemented" + fun _ _ _ _ -> + Misc.fatal_error "not implemented (Cfg_selectgen#emit_expr_aux_exit)" method emit_expr_aux_trywith : environment -> @@ -305,11 +313,13 @@ class virtual selector_generic = Debuginfo.t -> Cmm.kind_for_unboxing -> Reg.t array option = - fun _ _ _ _ _ _ _ _ -> Misc.fatal_error "not implemented" + fun _ _ _ _ _ _ _ _ -> + Misc.fatal_error "not implemented (Cfg_selectgen#emit_expr_aux_trywith)" method emit_return : environment -> Cmm.expression -> Cmm.trap_action list -> unit = - fun _ _ _ -> Misc.fatal_error "not implemented" + fun _env _exp _traps -> + Misc.fatal_error "not implemented (Cfg_selectgen#emit_return)" method emit_tail_apply : environment -> @@ -318,7 +328,8 @@ class virtual selector_generic = Cmm.expression list -> Debuginfo.t -> unit = - fun _ _ _ _ _ -> Misc.fatal_error "not implemented" + fun _ _ _ _ _ -> + Misc.fatal_error "not implemented (Cfg_selectgen#emit_tail_apply)" method emit_tail_ifthenelse : environment -> @@ -330,7 +341,8 @@ class virtual selector_generic = Debuginfo.t -> Cmm.kind_for_unboxing -> unit = - fun _ _ _ _ _ _ _ _ -> Misc.fatal_error "not implemented" + fun _ _ _ _ _ _ _ _ -> + Misc.fatal_error "not implemented (Cfg_selectgen#emit_tail_ifthenelse)" method emit_tail_switch : environment -> @@ -340,7 +352,8 @@ class virtual selector_generic = Debuginfo.t -> Cmm.kind_for_unboxing -> unit = - fun _ _ _ _ _ _ -> Misc.fatal_error "not implemented" + fun _ _ _ _ _ _ -> + Misc.fatal_error "not implemented (Cfg_selectgen#emit_tail_switch)" method emit_tail_catch : environment -> @@ -354,7 +367,8 @@ class virtual selector_generic = Cmm.expression -> Cmm.kind_for_unboxing -> unit = - fun _ _ _ _ _ -> Misc.fatal_error "not implemented" + fun _ _ _ _ _ -> + Misc.fatal_error "not implemented (Cfg_selectgen#emit_tail_catch)" method emit_tail_trywith : environment -> @@ -365,5 +379,13 @@ class virtual selector_generic = Debuginfo.t -> Cmm.kind_for_unboxing -> unit = - fun _ _ _ _ _ _ _ -> Misc.fatal_error "not implemented" + fun _ _ _ _ _ _ _ -> + Misc.fatal_error "not implemented (Cfg_selectgen#emit_tail_trywith)" + + method emit_fundecl + : future_funcnames:Misc.Stdlib.String.Set.t -> + Cmm.fundecl -> + Cfg_with_layout.t = + fun ~future_funcnames:_ _ -> + Misc.fatal_error "not implemented (Cfg_selectgen#emit_fundecl)" end diff --git a/backend/cfg_selectgen.mli b/backend/cfg_selectgen.mli index 6fdc7353770..10100995480 100644 --- a/backend/cfg_selectgen.mli +++ b/backend/cfg_selectgen.mli @@ -291,4 +291,9 @@ class virtual selector_generic : method emit_return : environment -> Cmm.expression -> Cmm.trap_action list -> unit + + method emit_fundecl : + future_funcnames:Misc.Stdlib.String.Set.t -> + Cmm.fundecl -> + Cfg_with_layout.t end From e3c68de037d586e948f36133dc70f5119be1fb50 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 19 Sep 2024 13:50:59 +0100 Subject: [PATCH 57/76] Fix poll_attr_prologue reference file --- .../tests/asmcomp/poll_attr_prologue.compilers.reference | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference b/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference index b8fac05d786..c4f1eb50862 100644 --- a/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference +++ b/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference @@ -1,5 +1,3 @@ File "poll_attr_prologue.ml", line 1: -Error: Function with poll-error attribute contains polling points: - function call at File "poll_attr_prologue.ml", line 17, characters 15-38 - (plus compiler-inserted polling point(s) in prologue and/or loop back edges) +Error: Function with poll-error attribute contains polling points (inserted by the compiler) From 1caa00f0e8d31f1e78cefb0e4039027ad698cb19 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 19 Sep 2024 14:22:13 +0100 Subject: [PATCH 58/76] Fix poll_attr_prologue reference file, second file --- .../tests/asmcomp/poll_attr_prologue.compilers.reference | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/ocaml/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference b/ocaml/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference index b8fac05d786..c4f1eb50862 100644 --- a/ocaml/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference +++ b/ocaml/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference @@ -1,5 +1,3 @@ File "poll_attr_prologue.ml", line 1: -Error: Function with poll-error attribute contains polling points: - function call at File "poll_attr_prologue.ml", line 17, characters 15-38 - (plus compiler-inserted polling point(s) in prologue and/or loop back edges) +Error: Function with poll-error attribute contains polling points (inserted by the compiler) From 089c93fa027f027ceb789efd3dc54884512566ac Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 19 Sep 2024 14:45:45 +0100 Subject: [PATCH 59/76] The actual fix for the polling test --- testsuite/tests/asmcomp/poll_attr_prologue.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/testsuite/tests/asmcomp/poll_attr_prologue.ml b/testsuite/tests/asmcomp/poll_attr_prologue.ml index 9fdbb57b6f1..72838ac5057 100644 --- a/testsuite/tests/asmcomp/poll_attr_prologue.ml +++ b/testsuite/tests/asmcomp/poll_attr_prologue.ml @@ -11,7 +11,7 @@ *) -let[@poll error] rec c x l = +let[@poll error][@loop never] rec c x l = match l with | [] -> 0 | _ :: tl -> (c[@tailcall]) (x+1) tl From 2d53231547a2200d2167d48bcc5c257653d90eda Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 19 Sep 2024 14:45:51 +0100 Subject: [PATCH 60/76] Revert "Fix poll_attr_prologue reference file" This reverts commit e3c68de037d586e948f36133dc70f5119be1fb50. --- .../tests/asmcomp/poll_attr_prologue.compilers.reference | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference b/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference index c4f1eb50862..b8fac05d786 100644 --- a/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference +++ b/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference @@ -1,3 +1,5 @@ File "poll_attr_prologue.ml", line 1: -Error: Function with poll-error attribute contains polling points (inserted by the compiler) +Error: Function with poll-error attribute contains polling points: + function call at File "poll_attr_prologue.ml", line 17, characters 15-38 + (plus compiler-inserted polling point(s) in prologue and/or loop back edges) From d72902223f2bdada1973d5d0094f6df265157cbc Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 19 Sep 2024 14:45:56 +0100 Subject: [PATCH 61/76] Revert "Fix poll_attr_prologue reference file, second file" This reverts commit 1caa00f0e8d31f1e78cefb0e4039027ad698cb19. --- .../tests/asmcomp/poll_attr_prologue.compilers.reference | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ocaml/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference b/ocaml/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference index c4f1eb50862..b8fac05d786 100644 --- a/ocaml/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference +++ b/ocaml/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference @@ -1,3 +1,5 @@ File "poll_attr_prologue.ml", line 1: -Error: Function with poll-error attribute contains polling points (inserted by the compiler) +Error: Function with poll-error attribute contains polling points: + function call at File "poll_attr_prologue.ml", line 17, characters 15-38 + (plus compiler-inserted polling point(s) in prologue and/or loop back edges) From 59462243f5c9c4520c970f7be2d3b0f99ace2067 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Wed, 18 Sep 2024 13:33:48 +0100 Subject: [PATCH 62/76] Use old behaviour for Includemod reporting (cherry picked from commit 3dc57a3d3e8d67a2882a02bff64890c14622220f) --- ocaml/typing/typemod.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/ocaml/typing/typemod.ml b/ocaml/typing/typemod.ml index cf1e9fa1f49..7a3bafd75a0 100644 --- a/ocaml/typing/typemod.ml +++ b/ocaml/typing/typemod.ml @@ -3662,6 +3662,11 @@ let type_implementation target modulename initial_env ast = in Unit_info.Artifact.from_filename cmi_file in + (* We use pre-5.2 behaviour as regards which interface-related file + is reported in error messages. *) + let compiled_intf_file_name = + Unit_info.Artifact.filename compiled_intf_file + in let dclsig = Env.read_signature import compiled_intf_file ~add_binding:false in @@ -3676,7 +3681,7 @@ let type_implementation target modulename initial_env ast = let coercion, shape = Profile.record_call "check_sig" (fun () -> Includemod.compunit initial_env ~mark:Mark_positive - sourcefile sg source_intf dclsig shape) + sourcefile sg compiled_intf_file_name dclsig shape) in (* Check the _mli_ against the argument type, since the mli determines the visible type of the module and that's what needs to conform to From e8bf7ef051e9289b37d71803d198da26fa22263d Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 19 Sep 2024 14:55:29 +0100 Subject: [PATCH 63/76] Fix caml_floatarray_create_local (#3051) --- ocaml/runtime/array.c | 7 ++ ocaml/runtime4/array.c | 7 ++ .../typing-local/local_floatarray_test.ml | 67 +++++++++++++++++++ 3 files changed, 81 insertions(+) create mode 100644 ocaml/testsuite/tests/typing-local/local_floatarray_test.ml diff --git a/ocaml/runtime/array.c b/ocaml/runtime/array.c index b7bc0a48833..e7faf0b463d 100644 --- a/ocaml/runtime/array.c +++ b/ocaml/runtime/array.c @@ -396,6 +396,13 @@ CAMLprim value caml_floatarray_create(value len) CAMLprim value caml_floatarray_create_local(value len) { mlsize_t wosize = Long_val(len) * Double_wosize; + + if (wosize == 0) + return Atom(0); + + if (wosize > Max_unboxed_float_array_wosize) + caml_invalid_argument("Float.Array.create_local"); + return caml_alloc_local (wosize, Double_array_tag); } diff --git a/ocaml/runtime4/array.c b/ocaml/runtime4/array.c index 49369bf35b9..ae3306028f6 100644 --- a/ocaml/runtime4/array.c +++ b/ocaml/runtime4/array.c @@ -404,6 +404,13 @@ CAMLprim value caml_floatarray_create(value len) CAMLprim value caml_floatarray_create_local(value len) { mlsize_t wosize = Long_val(len) * Double_wosize; + + if (wosize == 0) + return Atom(0); + + if (wosize > Max_unboxed_float_array_wosize) + caml_invalid_argument("Float.Array.create_local"); + return caml_alloc_local (wosize, Double_array_tag); } diff --git a/ocaml/testsuite/tests/typing-local/local_floatarray_test.ml b/ocaml/testsuite/tests/typing-local/local_floatarray_test.ml new file mode 100644 index 00000000000..22317340067 --- /dev/null +++ b/ocaml/testsuite/tests/typing-local/local_floatarray_test.ml @@ -0,0 +1,67 @@ +(* TEST *) + +type t = Float.Array.t + +external create_local : int -> local_ t = "caml_floatarray_create_local" + +external get : local_ t -> int -> float = "%floatarray_safe_get" +external set : local_ t -> int -> float -> unit = "%floatarray_safe_set" + +external unsafe_get : local_ t -> int -> float = "%floatarray_unsafe_get" +external unsafe_set : local_ t -> int -> float -> unit = "%floatarray_unsafe_set" + +let create_local ~len x = exclave_ + match create_local len with + | uninit -> + for i = 0 to len - 1 do + unsafe_set uninit i x + done; + uninit + | exception Invalid_argument _ -> + failwith "invalid length" + +let create_local_length_check () = + try + let _ : t = create_local ~len:(-1) 0.0 in + assert false + with _ -> () + +let create_local_zero_length_check () = + let _ : t = create_local ~len:(0) 0.0 in + () + +let safe_accesses () = + let rec test ~len = + if len = 10_000 then () + else + let arr = create_local ~len 1. in + for i = 0 to len - 1 do + set arr i (Float.of_int i) + done; + test ~len:(len + 1); + for i = 0 to len - 1 do + assert(get arr i = Float.of_int i); + done + in + test ~len:0 + +let unsafe_accesses () = + let rec test ~len = + if len = 10_000 then () + else + let arr = create_local ~len 1. in + for i = 0 to len - 1 do + unsafe_set arr i (Float.of_int i) + done; + test ~len:(len + 1); + for i = 0 to len - 1 do + assert (unsafe_get arr i = Float.of_int i); + done + in + test ~len:0 + +let () = + create_local_length_check (); + create_local_zero_length_check (); + safe_accesses (); + unsafe_accesses () From 994e20d2a3ea47099d9afb276b72ac8d4ecb184c Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Thu, 19 Sep 2024 17:49:28 +0100 Subject: [PATCH 64/76] Add 5.2-to-review --- 5.2-to-review | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100644 5.2-to-review diff --git a/5.2-to-review b/5.2-to-review new file mode 100644 index 00000000000..b94aba71322 --- /dev/null +++ b/5.2-to-review @@ -0,0 +1,18 @@ +merge-5.2-staging: +59462243f5c9c4520c970f7be2d3b0f99ace2067 Use old behaviour for Includemod reporting => lmaurer to review after testing, which is in progress +8cb65cbfb2d543e883dd7557a082b60974e4cd6d Fix chamelon => chamelon may need more work (see flambda-dev) +b44913db6e6755c593238a3fc4fa7146fa8e9cde Merge with main, and revert minus-23 magic changes => merge should be redone and diffed against this rev +-- The following is in effect a single merge (see below): +bac195af1fb487ccea799943f5666403bd78bfae dynlink dune again +8691c427ef0aee9181a2ebe655ea2ce631b22f5c Add jkind_axis to modules_without_implementation +764f730e5da69c373a7c03977e01b56893e9062f Dubious merge fixes +3970ad5e7ca99cfb1e60dd8c5e256669fe1ff726 Merge fixes +4b06f1928848af7c31aabe74f26a3f5a9b8818a5 Fixes to Select_utils required by previous merge => mshinwell confirms this changeset is ok +b180783b26b342885ee267ccfb3fa14778263c2d Merge remote-tracking branch 'flambda-backend/main' into merge-5.2 + => merge should be redone without resolving conflicts and then diffed directly against + bac195af1fb487ccea799943f5666403bd78bfae as not all fixes were committed with the merge itself (but some were) + +merge-5.2: +13118bd5399c0943ef00c0e1d878659e8bcf5bd3 Promote tests +87d44113da8367a0285b01f21b1a170d5f37e0a0 Fixes to odoc => lmaurer to review + From 3e7505248c8cf9e4bd52efe1e6a8f955ce7a4d35 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Mon, 2 Sep 2024 13:36:27 +0100 Subject: [PATCH 65/76] Better fix for Unix Mutex usage (cherry picked from commit cbed7b3526eeda460b3d545424728a6559cd01b7) (cherry picked from commit f857b48ea65805097948b2f2d07bb80e3d14a9f4) --- ocaml/otherlibs/unix/unix_unix.ml | 25 +++++++++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) diff --git a/ocaml/otherlibs/unix/unix_unix.ml b/ocaml/otherlibs/unix/unix_unix.ml index b24875cfcce..172048b10d4 100644 --- a/ocaml/otherlibs/unix/unix_unix.ml +++ b/ocaml/otherlibs/unix/unix_unix.ml @@ -939,8 +939,29 @@ type popen_process = let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t) -(* CR ocaml 5 all-runtime5: remove lazy, which is here to stop: - "Must initialize systhreads library before using Mutex" *) +(* CR ocaml 5 all-runtime5: go back to the normal [Mutex]. *) + +module Mutex : sig + type t + val create : unit -> t + val protect : t -> (unit -> 'a) -> 'a +end = struct + type t = Mutex.t option + + external runtime5 : unit -> bool = "%runtime5" + + let create () = + (* On runtime4, systhreads must be linked to use [Mutex], which is + error-prone to ensure. The use of [Mutex] here is new in 5.2.0, so + we just omit it for runtime4, which doesn't have parallelism. *) + if runtime5 () then Some (Mutex.create ()) else None + + let protect t f = + match t with + | None -> f () + | Some mutex -> Mutex.protect mutex f +end + let popen_mutex = lazy (Mutex.create ()) let open_proc prog args envopt proc input output error = From 657ff880921cf5a1726f831b55ca9bbbe663f314 Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Fri, 20 Sep 2024 04:50:40 -0400 Subject: [PATCH 66/76] Fix issues from a merge between `merge-5.2-staging` and `main` (#3053) * Fix issues from merge * Fix clear bug in unboxed product tests --- ocaml/otherlibs/dynlink/dune | 2 ++ ocaml/parsing/parser.mly | 4 +-- .../tests/typing-layouts-products/basics.ml | 35 ++++++++++++------- ocaml/typing/oprint.ml | 12 +++++-- ocaml/typing/outcometree.mli | 1 + ocaml/typing/printtyp.ml | 10 ++---- ocaml/typing/typecore.ml | 9 ++--- 7 files changed, 44 insertions(+), 29 deletions(-) diff --git a/ocaml/otherlibs/dynlink/dune b/ocaml/otherlibs/dynlink/dune index 72251a2c2a7..ec1f8ce698b 100644 --- a/ocaml/otherlibs/dynlink/dune +++ b/ocaml/otherlibs/dynlink/dune @@ -358,6 +358,8 @@ (copy_files ../../utils/profile.mli) +(copy_files ../../utils/profile_counters_functions.mli) + (copy_files ../../utils/consistbl.mli) (copy_files ../../utils/terminfo.mli) diff --git a/ocaml/parsing/parser.mly b/ocaml/parsing/parser.mly index 6f017f07a31..a5d303c653c 100644 --- a/ocaml/parsing/parser.mly +++ b/ocaml/parsing/parser.mly @@ -4572,6 +4572,8 @@ delimited_type_supporting_local_open: tags = name_tag_list RBRACKET { Ptyp_variant(fields, Closed, Some tags) } + | HASHLPAREN unboxed_tuple_type_body RPAREN + { Ptyp_unboxed_tuple $2 } ) { $1 } ; @@ -4621,8 +4623,6 @@ atomic_type: { Ptyp_open (mod_ident, type_) } | QUOTE ident = ident { Ptyp_var ident } - | HASHLPAREN unboxed_tuple_type_body RPAREN - { Ptyp_unboxed_tuple $2 } | UNDERSCORE { Ptyp_any } ) diff --git a/ocaml/testsuite/tests/typing-layouts-products/basics.ml b/ocaml/testsuite/tests/typing-layouts-products/basics.ml index 2e5cdf46865..d044c48f7c3 100644 --- a/ocaml/testsuite/tests/typing-layouts-products/basics.ml +++ b/ocaml/testsuite/tests/typing-layouts-products/basics.ml @@ -494,8 +494,11 @@ module type S_constrain_type_jkind_deeper' = type t3 = #(t2 * bool * int64#) type t4 = #(float# * t3 * int) end -Uncaught exception: File "ocaml/typing/printtyp.ml", line 1345, characters 27-33: Assertion failed - +type ('a : float64 & ((value & float64) & value & bits64) & value) + t_constraint +module F : + functor (X : S_constrain_type_jkind_deeper') -> + sig type r = X.t4 t_constraint end |}] (***********************************************) @@ -698,7 +701,7 @@ Line 2, characters 37-44: ^^^^^^^ Error: This expression has type "#('a * 'b)" but an expression was expected of type "('c : value)" - The layout of #('a * 'b) is '_representable_layout_350 & '_representable_layout_351 + The layout of #('a * 'b) is '_representable_layout_366 & '_representable_layout_367 because it is an unboxed tuple. But the layout of #('a * 'b) must be a sublayout of value because it's the type of the recursive variable x. @@ -714,7 +717,7 @@ Line 1, characters 21-29: ^^^^^^^^ Error: This expression has type "#('a * 'b)" but an expression was expected of type "('c : value)" - The layout of #('a * 'b) is '_representable_layout_357 & '_representable_layout_358 + The layout of #('a * 'b) is '_representable_layout_373 & '_representable_layout_374 because it is an unboxed tuple. But the layout of #('a * 'b) must be a sublayout of value because it's the type of the recursive variable _x. @@ -770,8 +773,9 @@ type t3 = #(int * bool) array type t4 = #(string * #(float# * bool option)) array [%%expect{| type ('a : value & value) t1 = 'a array -Uncaught exception: File "ocaml/typing/printtyp.ml", line 1345, characters 27-33: Assertion failed - +type ('a : bits64 & (value & float64)) t2 = 'a array +type t3 = #(int * bool) array +type t4 = #(string * #(float# * bool option)) array |}] (* CR layouts v7.1: This example demonstrates a bug in type inference that we @@ -786,8 +790,15 @@ let _ = [| #(1,2) |] Line 1, characters 11-17: 1 | let _ = [| #(1,2) |] ^^^^^^ -Error: Uncaught exception: Typecore.Error(_, _, _) - +Error: This expression has type "#('a * 'b)" + but an expression was expected of type + "('c : '_representable_layout_397 & '_representable_layout_398)" + The kind of #('a * 'b) is + '_representable_layout_397 & '_representable_layout_398 + because it is an unboxed tuple. + But the kind of #('a * 'b) must be a subkind of + '_representable_layout_397 & '_representable_layout_398 + because it's the type of an array element. |}] let _ = Array.init 3 (fun _ -> #(1,2)) @@ -797,7 +808,7 @@ Line 1, characters 31-37: ^^^^^^ Error: This expression has type "#('a * 'b)" but an expression was expected of type "('c : value)" - The layout of #('a * 'b) is '_representable_layout_380 & '_representable_layout_381 + The layout of #('a * 'b) is '_representable_layout_404 & '_representable_layout_405 because it is an unboxed tuple. But the layout of #('a * 'b) must be a sublayout of value because of layout requirements from an imported definition. @@ -865,7 +876,7 @@ Line 2, characters 25-26: ^ Error: This expression has type "('a : value)" but an expression was expected of type "#('b * 'c)" - The layout of #('a * 'b) is '_representable_layout_426 & '_representable_layout_427 + The layout of #('a * 'b) is '_representable_layout_450 & '_representable_layout_451 because it is an unboxed tuple. But the layout of #('a * 'b) must be a sublayout of value because it's the type of a term-level argument to a class constructor. @@ -882,7 +893,7 @@ Line 1, characters 13-19: ^^^^^^ Error: This expression has type "#('a * 'b)" but an expression was expected of type "('c : value)" - The layout of #('a * 'b) is '_representable_layout_431 & '_representable_layout_432 + The layout of #('a * 'b) is '_representable_layout_455 & '_representable_layout_456 because it is an unboxed tuple. But the layout of #('a * 'b) must be a sublayout of value because it's the type of a lazy expression. @@ -932,7 +943,7 @@ Line 1, characters 28-34: ^^^^^^ Error: This expression has type "#('a * 'b)" but an expression was expected of type "('c : value)" - The layout of #('a * 'b) is '_representable_layout_461 & '_representable_layout_462 + The layout of #('a * 'b) is '_representable_layout_485 & '_representable_layout_486 because it is an unboxed tuple. But the layout of #('a * 'b) must be a sublayout of value because the type argument of option has layout value. diff --git a/ocaml/typing/oprint.ml b/ocaml/typing/oprint.ml index 209015d5652..29ff1d284bf 100644 --- a/ocaml/typing/oprint.ml +++ b/ocaml/typing/oprint.ml @@ -356,9 +356,15 @@ let print_out_jkind_const ppf ojkind = pp_element ~nested:false ppf ojkind let print_out_jkind ppf ojkind = - match ojkind with - | Ojkind_var v -> fprintf ppf "%s" v - | Ojkind_const jkind -> print_out_jkind_const ppf jkind + let rec pp_element ~nested ppf ojkind = + match ojkind with + | Ojkind_var v -> fprintf ppf "%s" v + | Ojkind_const jkind -> print_out_jkind_const ppf jkind + | Ojkind_product ts -> + let pp_sep ppf () = Format.fprintf ppf "@ & " in + Misc.pp_nested_list ~nested ~pp_element ~pp_sep ppf ts + in + pp_element ~nested:false ppf ojkind let print_out_jkind_annot ppf = function | None -> () diff --git a/ocaml/typing/outcometree.mli b/ocaml/typing/outcometree.mli index 25b3d405dec..3b3094c2e28 100644 --- a/ocaml/typing/outcometree.mli +++ b/ocaml/typing/outcometree.mli @@ -113,6 +113,7 @@ type out_jkind_const = and out_jkind = | Ojkind_const of out_jkind_const | Ojkind_var of string + | Ojkind_product of out_jkind list (* should be empty if all the jkind annotations are missing *) and out_vars_jkinds = (string * out_jkind option) list diff --git a/ocaml/typing/printtyp.ml b/ocaml/typing/printtyp.ml index ef3849aa352..f61e17cdd19 100644 --- a/ocaml/typing/printtyp.ml +++ b/ocaml/typing/printtyp.ml @@ -1339,10 +1339,7 @@ let out_jkind_option_of_jkind jkind = | Const jkind -> out_jkind_of_const_jkind jkind | Var v -> Ojkind_var (Jkind.Sort.Var.name v) | Product jkinds -> - Ojkind_const (Ojkind_const_product (List.map desc_to_out_const_jkind jkinds)) - and desc_to_out_const_jkind : Jkind.Desc.t -> out_jkind_const = function - | Const jkind -> Jkind.Const.to_out_jkind_const jkind - | Var _ | Product _ -> assert false (* XXX mshinwell *) + Ojkind_product (List.map desc_to_out_jkind jkinds) in let desc = Jkind.get jkind in let elide = @@ -2734,10 +2731,7 @@ let trees_of_type_expansion' | Const clay -> out_jkind_of_const_jkind clay | Var v -> Ojkind_var (Jkind.Sort.Var.name v) | Product ds -> - Ojkind_const (Ojkind_const_product (List.map okind_const_of_desc ds)) - and okind_const_of_desc : Jkind.Desc.t -> _ = function - | Const const -> Jkind.Const.to_out_jkind_const const - | Var _ | Product _ -> assert false (* XXX mshinwell *) + Ojkind_product (List.map okind_of_desc ds) in let okind = okind_of_desc (Jkind.get jkind) in Otyp_jkind_annot (out, okind) diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index 40bff454467..64779822608 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -1487,7 +1487,7 @@ let solve_Ppat_tuple ~refine ~alloc_mode loc env args expected_ty = (* This assumes the [args] have already been reordered according to the [expected_ty], if needed. *) -let solve_Ppat_unboxed_tuple ~alloc_mode loc env args expected_ty = +let solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc env args expected_ty = let arity = List.length args in let arg_modes = match alloc_mode.tuple_modes with @@ -1513,7 +1513,7 @@ let solve_Ppat_unboxed_tuple ~alloc_mode loc env args expected_ty = newgenty (Tunboxed_tuple (List.map (fun (lbl, _, t, _, _) -> lbl, t) ann)) in let expected_ty = generic_instance expected_ty in - unify_pat_types loc env ty expected_ty; + unify_pat_types_refine ~refine loc env ty expected_ty; ann let solve_constructor_annotation @@ -2534,7 +2534,8 @@ and type_pat_aux | Closed -> spl in let spl_ann = - solve_Ppat_unboxed_tuple ~alloc_mode loc !!penv args expected_ty + solve_Ppat_unboxed_tuple ~refine:false ~alloc_mode loc penv args + expected_ty in let pl = List.map (fun (lbl, p, t, alloc_mode, sort) -> @@ -3311,7 +3312,7 @@ let rec check_counter_example_pat pl)))) | Tpat_unboxed_tuple tpl -> let tpl_ann = - solve_Ppat_unboxed_tuple ~alloc_mode loc !!penv + solve_Ppat_unboxed_tuple ~refine ~alloc_mode loc penv (List.map (fun (l,t,_) -> l, t) tpl) expected_ty in From 58ced0d886d894f2369cc6e85c35aaf54ec50e10 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 20 Sep 2024 09:56:22 +0100 Subject: [PATCH 67/76] Update 5.2-to-review --- 5.2-to-review | 15 ++------------- 1 file changed, 2 insertions(+), 13 deletions(-) diff --git a/5.2-to-review b/5.2-to-review index b94aba71322..99215aa977f 100644 --- a/5.2-to-review +++ b/5.2-to-review @@ -1,18 +1,7 @@ merge-5.2-staging: -59462243f5c9c4520c970f7be2d3b0f99ace2067 Use old behaviour for Includemod reporting => lmaurer to review after testing, which is in progress +994e20d2a3ea47099d9afb276b72ac8d4ecb184c fix for Unix + Mutex => mshinwell will find a reviewer 8cb65cbfb2d543e883dd7557a082b60974e4cd6d Fix chamelon => chamelon may need more work (see flambda-dev) -b44913db6e6755c593238a3fc4fa7146fa8e9cde Merge with main, and revert minus-23 magic changes => merge should be redone and diffed against this rev --- The following is in effect a single merge (see below): -bac195af1fb487ccea799943f5666403bd78bfae dynlink dune again -8691c427ef0aee9181a2ebe655ea2ce631b22f5c Add jkind_axis to modules_without_implementation -764f730e5da69c373a7c03977e01b56893e9062f Dubious merge fixes -3970ad5e7ca99cfb1e60dd8c5e256669fe1ff726 Merge fixes -4b06f1928848af7c31aabe74f26a3f5a9b8818a5 Fixes to Select_utils required by previous merge => mshinwell confirms this changeset is ok -b180783b26b342885ee267ccfb3fa14778263c2d Merge remote-tracking branch 'flambda-backend/main' into merge-5.2 - => merge should be redone without resolving conflicts and then diffed directly against - bac195af1fb487ccea799943f5666403bd78bfae as not all fixes were committed with the merge itself (but some were) +b44913db6e6755c593238a3fc4fa7146fa8e9cde Merge with main, and revert minus-23 magic changes => merge should be redone and diffed against this rev [mshinwell checking] merge-5.2: 13118bd5399c0943ef00c0e1d878659e8bcf5bd3 Promote tests -87d44113da8367a0285b01f21b1a170d5f37e0a0 Fixes to odoc => lmaurer to review - From 4c907c71401ebf00ac6ecb55fdd5ef5d89ac9d51 Mon Sep 17 00:00:00 2001 From: Chris Casinghino Date: Fri, 20 Sep 2024 10:06:55 +0100 Subject: [PATCH 68/76] "fix" a regression in the 5.2 merge (#3004) * add failing test * "fix" by restoring old behavior (cherry picked from commit 8db5026a2c0f5149c4479bc0dfc9740d459d3ad0) --- ocaml/testsuite/tests/typing-modes/gadts.ml | 18 ++++++++++++++++++ ocaml/typing/typecore.ml | 3 ++- 2 files changed, 20 insertions(+), 1 deletion(-) create mode 100644 ocaml/testsuite/tests/typing-modes/gadts.ml diff --git a/ocaml/testsuite/tests/typing-modes/gadts.ml b/ocaml/testsuite/tests/typing-modes/gadts.ml new file mode 100644 index 00000000000..55a74f46450 --- /dev/null +++ b/ocaml/testsuite/tests/typing-modes/gadts.ml @@ -0,0 +1,18 @@ +(* TEST + expect; +*) + +(* An example where [type_argument] can refine modes using a gadt equation. *) +type _ t = + | A : bool t + +let id x = x + +let f (type output) ~(output : output t) = + match output with + | A -> (id : bool -> output) +[%%expect{| +type _ t = A : bool t +val id : 'a -> 'a = +val f : output:'output t -> bool -> 'output = +|}] diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index 64779822608..9741b784c72 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -5933,6 +5933,7 @@ and type_expect_ type_constraint env sty alloc_mode in let expected_mode = type_expect_mode ~loc ~env ~modes expected_mode in + let ty' = instance ty in let error_message_attr_opt = Builtin_attributes.error_message_attr sexp.pexp_attributes in let explanation = Option.map (fun msg -> Error_message_attr msg) @@ -5941,7 +5942,7 @@ and type_expect_ rue { exp_desc = arg.exp_desc; exp_loc = arg.exp_loc; - exp_type = instance ty; + exp_type = ty'; exp_attributes = arg.exp_attributes; exp_env = env; exp_extra = From aaefd8f9e5e645543a436c54e75569de89c45a50 Mon Sep 17 00:00:00 2001 From: Leo White Date: Fri, 20 Sep 2024 11:23:58 +0100 Subject: [PATCH 69/76] Support loosening monadic return modes in [type_argument] (#3052) --- ocaml/testsuite/tests/typing-local/local.ml | 63 ------- ocaml/testsuite/tests/typing-modes/modes.ml | 176 ++++++++++++++++++ ocaml/testsuite/tests/typing-unique/unique.ml | 14 -- ocaml/typing/typecore.ml | 4 +- 4 files changed, 177 insertions(+), 80 deletions(-) diff --git a/ocaml/testsuite/tests/typing-local/local.ml b/ocaml/testsuite/tests/typing-local/local.ml index 6f772845f3d..f4c1e500c86 100644 --- a/ocaml/testsuite/tests/typing-local/local.ml +++ b/ocaml/testsuite/tests/typing-local/local.ml @@ -397,69 +397,6 @@ Line 1, characters 21-35: Error: This value escapes its region. |}] -(* - * Modification of return modes in argument position - *) - -let use (local_ f : _ -> _ -> _) x y = - f x y -let result = use (+) 1 2 -[%%expect{| -val use : local_ ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = -val result : int = 3 -|}] - -let baduse (f : _ -> _ -> _) x y = lazy (f x y) -let result = baduse (fun a b -> exclave_ (a,b)) 1 2 -[%%expect{| -val baduse : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c lazy_t = -Line 2, characters 32-46: -2 | let result = baduse (fun a b -> exclave_ (a,b)) 1 2 - ^^^^^^^^^^^^^^ -Error: This expression is local because it is an exclave, - but was expected otherwise. -|}] - -(* - * Modification of parameter modes in argument position - *) - -let use_local (local_ f : _ -> _ -> _) x y = - f x y -let use_global (f : _ -> _ -> _) x y = f x y - -let foo x y = x +. y -let bar (local_ x) (local_ y) = let _ = x +. y in () - -let result = use_local foo 1. 2. -[%%expect{| -val use_local : local_ ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = -val use_global : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = -val foo : float -> float -> float = -val bar : local_ float -> local_ float -> unit = -val result : float = 3. -|}] - -let result = use_local bar 1. 2. -[%%expect{| -val result : unit = () -|}] - -let result = use_global foo 1. 2. -[%%expect{| -val result : float = 3. -|}] - -let result = use_global bar 1. 2. -[%%expect{| -Line 1, characters 24-27: -1 | let result = use_global bar 1. 2. - ^^^ -Error: This expression has type local_ float -> local_ float -> unit - but an expression was expected of type local_ 'a -> ('b -> 'c) -|}] - - (* * Closures and context locks *) diff --git a/ocaml/testsuite/tests/typing-modes/modes.ml b/ocaml/testsuite/tests/typing-modes/modes.ml index e3cff0f19f7..aec5419149d 100644 --- a/ocaml/testsuite/tests/typing-modes/modes.ml +++ b/ocaml/testsuite/tests/typing-modes/modes.ml @@ -376,3 +376,179 @@ Line 2, characters 38-41: ^^^ Error: The extension "mode" is disabled and cannot be used |}] + + +(* + * Modification of return modes in argument position + *) + +let use_local (f : _ -> _ -> _ @@ local) x y = + f x y +let result = use_local (^) "hello" " world" +[%%expect{| +val use_local : local_ ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = +val result : string = "hello world" +|}] + +let use_local_ret (f : _ -> _ @ local) x y = + let _ = f x in () +let global_ret : string -> string @ global = fun x -> x +let result = use_local_ret global_ret "hello" +[%%expect{| +val use_local_ret : ('a -> local_ 'b) -> 'a -> 'c -> unit = +val global_ret : string -> string = +val result : '_weak1 -> unit = +|}] + +let use_global_ret (f : _ -> _ @ global) x = lazy (f x) +let local_ret a = exclave_ (Some a) +let bad_use = use_global_ret local_ret "hello" +[%%expect{| +val use_global_ret : ('a -> 'b) -> 'a -> 'b lazy_t = +val local_ret : 'a -> local_ 'a option = +Line 3, characters 29-38: +3 | let bad_use = use_global_ret local_ret "hello" + ^^^^^^^^^ +Error: This expression has type 'a -> local_ 'a option + but an expression was expected of type 'b -> 'c +|}] + +let use_nonportable_ret (f : _ -> (_ -> _) @ nonportable) x y = + f x y +let portable_ret : string -> (string -> string) @ portable = + fun x y -> y +let result = use_nonportable_ret portable_ret "hello" " world" +[%%expect{| +val use_nonportable_ret : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = +val portable_ret : string -> (string -> string) @ portable = +val result : string = " world" +|}] + +let use_portable_ret (f : _ -> (_ -> _) @ portable) x y = + lazy ((f x) y) +let nonportable_ret : string -> (string -> string) @ nonportable = + fun x y -> x ^ y +let bad_use = use_portable_ret nonportable_ret "hello" " world" +[%%expect{| +val use_portable_ret : ('a -> ('b -> 'c) @ portable) -> 'a -> 'b -> 'c lazy_t = + +val nonportable_ret : string -> string -> string = +Line 5, characters 31-46: +5 | let bad_use = use_portable_ret nonportable_ret "hello" " world" + ^^^^^^^^^^^^^^^ +Error: This expression has type string -> string -> string + but an expression was expected of type 'a -> ('b -> 'c) @ portable +|}] + +let use_contended_ret (f : _ -> _ @ contended) x = + let _ = f x in () +let uncontended_ret : string -> string @ uncontended = + fun x -> x +let result = use_contended_ret uncontended_ret "hello" +[%%expect{| +val use_contended_ret : ('a -> 'b @ contended) -> 'a -> unit = +val uncontended_ret : string -> string = +val result : unit = () +|}] + +let use_uncontended_ret (f : _ -> _ @ uncontended) x = + let _ = f x in () +let contended_ret : string -> string @ contended = + fun x -> x +let bad_use = use_uncontended_ret contended_ret "hello" +[%%expect{| +val use_uncontended_ret : ('a -> 'b) -> 'a -> unit = +val contended_ret : string -> string @ contended = +Line 5, characters 34-47: +5 | let bad_use = use_uncontended_ret contended_ret "hello" + ^^^^^^^^^^^^^ +Error: This expression has type string -> string @ contended + but an expression was expected of type 'a -> 'b +|}] + +(* + * Modification of parameter modes in argument position + *) + +let use_local (local_ f : _ -> _ -> _) x y = + f x y +let use_global (f : _ -> _ -> _) x y = f x y + +let foo x y = x +. y +let bar (local_ x) (local_ y) = let _ = x +. y in () + +let result = use_local foo 1. 2. +[%%expect{| +val use_local : local_ ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = +val use_global : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = +val foo : float -> float -> float = +val bar : local_ float -> local_ float -> unit = +val result : float = 3. +|}] + +let result = use_local bar 1. 2. +[%%expect{| +val result : unit = () +|}] + +let result = use_global foo 1. 2. +[%%expect{| +val result : float = 3. +|}] + +let result = use_global bar 1. 2. +[%%expect{| +Line 1, characters 24-27: +1 | let result = use_global bar 1. 2. + ^^^ +Error: This expression has type local_ float -> local_ float -> unit + but an expression was expected of type local_ 'a -> ('b -> 'c) +|}] + +let use_portable_arg (f : (_ -> _) @ portable -> _) g = f g +let nonportable_arg (f @ nonportable) = f () +let result = use_portable_arg nonportable_arg (fun () -> ()) +[%%expect{| +val use_portable_arg : + ('a : any) ('b : any) 'c. + (('a -> 'b) @ portable -> 'c) -> ('a -> 'b) @ portable -> 'c = + +val nonportable_arg : (unit -> 'a) -> 'a = +val result : unit = () +|}] + +let use_nonportable_arg (f : (_ -> _) @ nonportable -> _) g = f g +let portable_arg (f @ portable) = f () +let bad_use = use_nonportable_arg portable_arg (fun () -> ()) +[%%expect{| +val use_nonportable_arg : + ('a : any) ('b : any) 'c. (('a -> 'b) -> 'c) -> ('a -> 'b) -> 'c = +val portable_arg : (unit -> 'a) @ portable -> 'a = +Line 3, characters 34-46: +3 | let bad_use = use_nonportable_arg portable_arg (fun () -> ()) + ^^^^^^^^^^^^ +Error: This expression has type (unit -> 'a) @ portable -> 'a + but an expression was expected of type ('b -> 'c) -> 'd +|}] + +let use_uncontended_arg (f : _ @ uncontended -> _) x = f x +let contended_arg (x @ contended) = () +let result = use_uncontended_arg contended_arg () +[%%expect{| +val use_uncontended_arg : ('a -> 'b) -> 'a -> 'b = +val contended_arg : 'a @ contended -> unit = +val result : unit = () +|}] + +let use_contended_arg (f : _ @ contended -> _) x = f x +let uncontended_arg (x @ uncontended) = () +let bad_use = use_contended_arg uncontended_arg () +[%%expect{| +val use_contended_arg : ('a @ contended -> 'b) -> 'a -> 'b = +val uncontended_arg : 'a -> unit = +Line 3, characters 32-47: +3 | let bad_use = use_contended_arg uncontended_arg () + ^^^^^^^^^^^^^^^ +Error: This expression has type 'a -> unit + but an expression was expected of type 'b @ contended -> 'c +|}] diff --git a/ocaml/testsuite/tests/typing-unique/unique.ml b/ocaml/testsuite/tests/typing-unique/unique.ml index 2d1bc3b77ef..15d93dfea12 100644 --- a/ocaml/testsuite/tests/typing-unique/unique.ml +++ b/ocaml/testsuite/tests/typing-unique/unique.ml @@ -588,20 +588,6 @@ Error: This expression has type int but an expression was expected of type string |}] - -let foo () = - let unique_ _bar : int -> int -> int = - ((fun y z -> z) : int -> unique_ (int -> int)) in - () -[%%expect{| -Line 3, characters 4-50: -3 | ((fun y z -> z) : int -> unique_ (int -> int)) in - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This expression has type int -> unique_ (int -> int) - but an expression was expected of type int -> int -> int -|}] - - let return_local : local_ 'a -> local_ 'a = fun x -> x let return_global : local_ 'a -> int = fun x -> 0 [%%expect{| diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index 4b93626adb1..534a60cc13e 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -7365,9 +7365,7 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg Tarrow(_, ty_arg, ty_res, _) when lv' = generic_level || not !Clflags.principal -> let ty_res', ty_res, changed = loosen_arrow_modes ty_res' ty_res in - let {comonadic; monadic} = mret in - let comonadic, changed' = Alloc.Comonadic.newvar_below comonadic in - let mret = {comonadic; monadic} in + let mret, changed' = Alloc.newvar_below mret in let marg, changed'' = Alloc.newvar_above marg in if changed || changed' || changed'' then newty2 ~level:lv' (Tarrow((l, marg, mret), ty_arg', ty_res', commu_ok)), From 5a33ef71f8d7058fffb1adf3363e017f1c563d5d Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 20 Sep 2024 12:59:24 +0100 Subject: [PATCH 70/76] Update 5.2-to-review --- 5.2-to-review | 1 - 1 file changed, 1 deletion(-) diff --git a/5.2-to-review b/5.2-to-review index 99215aa977f..f0cbff583e7 100644 --- a/5.2-to-review +++ b/5.2-to-review @@ -1,7 +1,6 @@ merge-5.2-staging: 994e20d2a3ea47099d9afb276b72ac8d4ecb184c fix for Unix + Mutex => mshinwell will find a reviewer 8cb65cbfb2d543e883dd7557a082b60974e4cd6d Fix chamelon => chamelon may need more work (see flambda-dev) -b44913db6e6755c593238a3fc4fa7146fa8e9cde Merge with main, and revert minus-23 magic changes => merge should be redone and diffed against this rev [mshinwell checking] merge-5.2: 13118bd5399c0943ef00c0e1d878659e8bcf5bd3 Promote tests From f3a5fa9005dcbca6f87d8eaaa622028d6ff9cb31 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 20 Sep 2024 13:09:00 +0100 Subject: [PATCH 71/76] Backport upstream PR13318, Gc.create_alarm fix: 43b80ade08939e20b3a0e03bb4d0b262d137c2df --- ocaml/stdlib/gc.ml | 7 ++++--- testsuite/tests/callback/test_gc_alarm.ml | 14 ++++++++++++++ 2 files changed, 18 insertions(+), 3 deletions(-) create mode 100644 testsuite/tests/callback/test_gc_alarm.ml diff --git a/ocaml/stdlib/gc.ml b/ocaml/stdlib/gc.ml index 4443334887f..f832fb4db5f 100644 --- a/ocaml/stdlib/gc.ml +++ b/ocaml/stdlib/gc.ml @@ -127,10 +127,11 @@ let delete_alarm a = Atomic.set a false (* We use [@inline never] to ensure [arec] is never statically allocated (which would prevent installation of the finaliser). *) let [@inline never] create_alarm f = - let arec = { active = Atomic.make true; f = f } in - Domain.at_exit (fun () -> delete_alarm arec.active); + let alarm = Atomic.make true in + Domain.at_exit (fun () -> delete_alarm alarm); + let arec = { active = alarm; f = f } in finalise call_alarm arec; - arec.active + alarm module Memprof = diff --git a/testsuite/tests/callback/test_gc_alarm.ml b/testsuite/tests/callback/test_gc_alarm.ml new file mode 100644 index 00000000000..9452470cf15 --- /dev/null +++ b/testsuite/tests/callback/test_gc_alarm.ml @@ -0,0 +1,14 @@ +(* TEST *) + +let success () = exit 0 +let failure () = failwith "The end was reached without triggering the GC alarm" + +let () = + let _ = Gc.create_alarm success in + let g = Array.init 120000 (fun i -> Array.init 1 (fun i -> i)) in + for i = 0 to 10000 do + let a = Array.init 12000 (fun i -> i) in + g.(i) <- a; + a.(0) <- 42; + done; + failure () From 45b59462c19fbc133c48b553ef0cd4fc7ce62e26 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 20 Sep 2024 13:11:59 +0100 Subject: [PATCH 72/76] Update 5.2-to-review --- 5.2-to-review | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/5.2-to-review b/5.2-to-review index f0cbff583e7..bdaca62363d 100644 --- a/5.2-to-review +++ b/5.2-to-review @@ -1,5 +1,5 @@ merge-5.2-staging: -994e20d2a3ea47099d9afb276b72ac8d4ecb184c fix for Unix + Mutex => mshinwell will find a reviewer +3e7505248c8cf9e4bd52efe1e6a8f955ce7a4d35 fix for Unix + Mutex => mshinwell will find a reviewer 8cb65cbfb2d543e883dd7557a082b60974e4cd6d Fix chamelon => chamelon may need more work (see flambda-dev) merge-5.2: From 43452fb9789a697ab0acae2014dc92f4ad4d0194 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 20 Sep 2024 13:55:45 +0100 Subject: [PATCH 73/76] Update 5.2-to-review --- 5.2-to-review | 1 - 1 file changed, 1 deletion(-) diff --git a/5.2-to-review b/5.2-to-review index bdaca62363d..b4c7f3628e2 100644 --- a/5.2-to-review +++ b/5.2-to-review @@ -1,5 +1,4 @@ merge-5.2-staging: -3e7505248c8cf9e4bd52efe1e6a8f955ce7a4d35 fix for Unix + Mutex => mshinwell will find a reviewer 8cb65cbfb2d543e883dd7557a082b60974e4cd6d Fix chamelon => chamelon may need more work (see flambda-dev) merge-5.2: From ea1bea0fe2b1ae3b10e8cdcfa9fc6559f8629508 Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 20 Sep 2024 15:05:35 +0100 Subject: [PATCH 74/76] Remove 5.2-to-review --- 5.2-to-review | 5 ----- 1 file changed, 5 deletions(-) delete mode 100644 5.2-to-review diff --git a/5.2-to-review b/5.2-to-review deleted file mode 100644 index b4c7f3628e2..00000000000 --- a/5.2-to-review +++ /dev/null @@ -1,5 +0,0 @@ -merge-5.2-staging: -8cb65cbfb2d543e883dd7557a082b60974e4cd6d Fix chamelon => chamelon may need more work (see flambda-dev) - -merge-5.2: -13118bd5399c0943ef00c0e1d878659e8bcf5bd3 Promote tests From 1b95e0acc9d7f5d388ce5d4e5e66825ac73ad6fa Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 20 Sep 2024 15:10:47 +0100 Subject: [PATCH 75/76] Fix conflicts in compile_common.ml --- ocaml/driver/compile_common.ml | 18 ++++-------------- 1 file changed, 4 insertions(+), 14 deletions(-) diff --git a/ocaml/driver/compile_common.ml b/ocaml/driver/compile_common.ml index 889b37f756b..3f4716e8fc4 100644 --- a/ocaml/driver/compile_common.ml +++ b/ocaml/driver/compile_common.ml @@ -103,13 +103,8 @@ let emit_signature info alerts tsg = Typemod.save_signature info.target info.module_name tsg info.env sg let interface ~hook_parse_tree ~hook_typed_tree info = -<<<<<<< HEAD - Profile.record_call (Unit_info.source_file info.target) @@ fun () -> -||||||| caebc8adff - Profile.record_call info.source_file @@ fun () -> -======= - Profile.(record_call (annotate_file_name info.source_file)) @@ fun () -> ->>>>>>> flambda-backend/main + Profile.(record_call (annotate_file_name ( + Unit_info.source_file info.target))) @@ fun () -> let ast = parse_intf info in hook_parse_tree ast; if Clflags.(should_stop_after Compiler_pass.Parsing) then () else begin @@ -145,13 +140,8 @@ let typecheck_impl i parsetree = (fun fmt {Typedtree.shape; _} -> Shape.print fmt shape) let implementation ~hook_parse_tree ~hook_typed_tree info ~backend = -<<<<<<< HEAD - Profile.record_call (Unit_info.source_file info.target) @@ fun () -> -||||||| caebc8adff - Profile.record_call info.source_file @@ fun () -> -======= - Profile.(record_call (annotate_file_name info.source_file)) @@ fun () -> ->>>>>>> flambda-backend/main + Profile.(record_call (annotate_file_name ( + Unit_info.source_file info.target))) @@ fun () -> let exceptionally () = let sufs = if info.native then Unit_info.[ cmx; obj ] From e1ee26b6629cc855c28b5cb8920507e215b339db Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Fri, 20 Sep 2024 15:26:00 +0100 Subject: [PATCH 76/76] Fix conflicts in testsuite --- .../testsuite/tests/typing-layouts/jkinds.ml | 22 +---- ocaml/testsuite/tests/typing-local/local.ml | 6 +- .../tests/typing-modal-kinds/basics.ml | 24 +---- .../tests/typing-modal-kinds/expected_mode.ml | 72 ++------------- ocaml/testsuite/tests/typing-modes/class.ml | 8 +- .../testsuite/tests/typing-modes/crossing.ml | 8 +- ocaml/testsuite/tests/typing-modes/modes.ml | 24 ++--- ocaml/testsuite/tests/typing-modes/mutable.ml | 8 +- ocaml/testsuite/tests/typing-unique/unique.ml | 92 ++----------------- .../tests/typing-unique/unique_analysis.ml | 16 +--- .../tests/typing-unique/unique_mod_class.ml | 18 +--- .../tests/typing-unique/unique_typedecl.ml | 10 -- 12 files changed, 43 insertions(+), 265 deletions(-) diff --git a/ocaml/testsuite/tests/typing-layouts/jkinds.ml b/ocaml/testsuite/tests/typing-layouts/jkinds.ml index 6c614862254..1baaed88db1 100644 --- a/ocaml/testsuite/tests/typing-layouts/jkinds.ml +++ b/ocaml/testsuite/tests/typing-layouts/jkinds.ml @@ -225,34 +225,14 @@ type a : value mod global unique once uncontended portable external_ type b : value mod local aliased many uncontended nonportable internal = a [%%expect{| type a : value mod global unique once uncontended portable external_ -<<<<<<< HEAD -Line 2, characters 0-73: -2 | type b : value mod local shared many uncontended nonportable internal = a - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The kind of type "a" is -||||||| caebc8adff -Line 2, characters 0-73: -2 | type b : value mod local shared many uncontended nonportable internal = a - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The kind of type a is -======= Line 2, characters 0-74: 2 | type b : value mod local aliased many uncontended nonportable internal = a ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The kind of type a is ->>>>>>> flambda-backend/main +Error: The kind of type "a" is value mod global unique uncontended portable external_ because of the definition of a at line 1, characters 0-68. -<<<<<<< HEAD But the kind of type "a" must be a subkind of value mod many uncontended - because of the definition of b at line 2, characters 0-73. -||||||| caebc8adff - But the kind of type a must be a subkind of value mod many uncontended - because of the definition of b at line 2, characters 0-73. -======= - But the kind of type a must be a subkind of value mod many uncontended because of the definition of b at line 2, characters 0-74. ->>>>>>> flambda-backend/main |}] (********************************************************) diff --git a/ocaml/testsuite/tests/typing-local/local.ml b/ocaml/testsuite/tests/typing-local/local.ml index 1eba2713390..ce80a2a3306 100644 --- a/ocaml/testsuite/tests/typing-local/local.ml +++ b/ocaml/testsuite/tests/typing-local/local.ml @@ -520,14 +520,12 @@ let result = use_global bar 1. 2. Line 1, characters 24-27: 1 | let result = use_global bar 1. 2. ^^^ -Error: This expression has type local_ float -> local_ float -> unit - but an expression was expected of type local_ 'a -> ('b -> 'c) +Error: This expression has type "local_ float -> local_ float -> unit" + but an expression was expected of type "local_ 'a -> ('b -> 'c)" |}] (* -======= ->>>>>>> flambda-backend/main * Closures and context locks *) diff --git a/ocaml/testsuite/tests/typing-modal-kinds/basics.ml b/ocaml/testsuite/tests/typing-modal-kinds/basics.ml index 0c56659d1f4..dd969dfcece 100644 --- a/ocaml/testsuite/tests/typing-modal-kinds/basics.ml +++ b/ocaml/testsuite/tests/typing-modal-kinds/basics.ml @@ -487,13 +487,7 @@ let hidden_string_unshare = Line 2, characters 75-76: 2 | let x : Hidden_string.t = Hidden_string.hide "hello" in ignore x; unique x ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] let hidden_int_unshare = @@ -520,13 +514,7 @@ let hidden_string_list_unshare = Line 4, characters 22-23: 4 | in ignore x; unique x ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] let hidden_int_list_unshare = @@ -627,13 +615,7 @@ let hidden_int64_u_unshare () = Line 3, characters 35-36: 3 | Int64_u.ignore x; Int64_u.unique x ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] let float_u_record_unshare = diff --git a/ocaml/testsuite/tests/typing-modal-kinds/expected_mode.ml b/ocaml/testsuite/tests/typing-modal-kinds/expected_mode.ml index 85c4cb93139..05a602bff6b 100644 --- a/ocaml/testsuite/tests/typing-modal-kinds/expected_mode.ml +++ b/ocaml/testsuite/tests/typing-modal-kinds/expected_mode.ml @@ -310,13 +310,7 @@ let string_unshare : _ -> unique_ string = fun x -> x Line 1, characters 52-53: 1 | let string_unshare : _ -> unique_ string = fun x -> x ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] let int_unshare : _ -> unique_ int = fun x -> x @@ -331,13 +325,7 @@ let string_list_unshare : _ -> unique_ string list = fun x -> x Line 1, characters 62-63: 1 | let string_list_unshare : _ -> unique_ string list = fun x -> x ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] let int_list_unshare : _ -> unique_ int list = fun x -> x @@ -346,13 +334,7 @@ let int_list_unshare : _ -> unique_ int list = fun x -> x Line 1, characters 56-57: 1 | let int_list_unshare : _ -> unique_ int list = fun x -> x ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] let function_unshare : _ -> unique_ (int -> int) = fun x -> x @@ -368,13 +350,7 @@ let hidden_string_unshare : _ -> unique_ Hidden_string.t = Line 2, characters 11-12: 2 | fun x -> x ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] let hidden_int_unshare : _ -> unique_ Hidden_int.t = @@ -390,13 +366,7 @@ let float_unshare : _ -> unique_ float = fun x -> x Line 1, characters 50-51: 1 | let float_unshare : _ -> unique_ float = fun x -> x ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] let float_u_unshare : _ -> unique_ float# = fun x -> x @@ -419,13 +389,7 @@ let float_u_record_unshare : _ -> unique_ float_u_record = Line 2, characters 11-12: 2 | fun x -> x ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] let float_u_record_list_unshare : @@ -436,13 +400,7 @@ let float_u_record_list_unshare : Line 3, characters 11-12: 3 | fun x -> x ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] let hidden_function_unshare : _ -> unique_ (int, int) Hidden_function.t = fun x -> x @@ -451,13 +409,7 @@ let hidden_function_unshare : _ -> unique_ (int, int) Hidden_function.t = fun x Line 1, characters 83-84: 1 | let hidden_function_unshare : _ -> unique_ (int, int) Hidden_function.t = fun x -> x ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] let function_list_unshare : _ -> unique_ (int -> int) list = @@ -467,11 +419,5 @@ let function_list_unshare : _ -> unique_ (int -> int) list = Line 2, characters 11-12: 2 | fun x -> x ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] diff --git a/ocaml/testsuite/tests/typing-modes/class.ml b/ocaml/testsuite/tests/typing-modes/class.ml index 65866e97056..4d0eb283185 100644 --- a/ocaml/testsuite/tests/typing-modes/class.ml +++ b/ocaml/testsuite/tests/typing-modes/class.ml @@ -43,13 +43,7 @@ let foo () = Line 5, characters 27-28: 5 | val k = unique_use s ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". Hint: This identifier cannot be used uniquely, because it is defined in a class. |}] diff --git a/ocaml/testsuite/tests/typing-modes/crossing.ml b/ocaml/testsuite/tests/typing-modes/crossing.ml index 81b43e62a5e..0fee3cb5408 100644 --- a/ocaml/testsuite/tests/typing-modes/crossing.ml +++ b/ocaml/testsuite/tests/typing-modes/crossing.ml @@ -37,9 +37,9 @@ Error: Signature mismatch: val f : unit -> [> `A ] is not included in val f : unit -> [ `A | `B of 'a -> 'a ] @ portable - The type unit -> [ `A | `B of 'a -> 'a ] + The type "unit -> [ `A | `B of 'a -> 'a ]" is not compatible with the type - unit -> [ `A | `B of 'a -> 'a ] @ portable + "unit -> [ `A | `B of 'a -> 'a ] @ portable" |}] (* In this example, the inferred type does not allow crossing portability, but @@ -75,8 +75,8 @@ Error: Signature mismatch: val f : unit -> local_ int is not included in val f : unit -> int - The type unit -> local_ int is not compatible with the type - unit -> int + The type "unit -> local_ int" is not compatible with the type + "unit -> int" |}] module M : sig diff --git a/ocaml/testsuite/tests/typing-modes/modes.ml b/ocaml/testsuite/tests/typing-modes/modes.ml index 3cec7aff17d..8dff2a5d273 100644 --- a/ocaml/testsuite/tests/typing-modes/modes.ml +++ b/ocaml/testsuite/tests/typing-modes/modes.ml @@ -409,8 +409,8 @@ val local_ret : 'a -> local_ 'a option = Line 3, characters 29-38: 3 | let bad_use = use_global_ret local_ret "hello" ^^^^^^^^^ -Error: This expression has type 'a -> local_ 'a option - but an expression was expected of type 'b -> 'c +Error: This expression has type "'a -> local_ 'a option" + but an expression was expected of type "'b -> 'c" |}] let use_nonportable_ret (f : _ -> (_ -> _) @ nonportable) x y = @@ -436,8 +436,8 @@ val nonportable_ret : string -> string -> string = Line 5, characters 31-46: 5 | let bad_use = use_portable_ret nonportable_ret "hello" " world" ^^^^^^^^^^^^^^^ -Error: This expression has type string -> string -> string - but an expression was expected of type 'a -> ('b -> 'c) @ portable +Error: This expression has type "string -> string -> string" + but an expression was expected of type "'a -> ('b -> 'c) @ portable" |}] let use_contended_ret (f : _ -> _ @ contended) x = @@ -462,8 +462,8 @@ val contended_ret : string -> string @ contended = Line 5, characters 34-47: 5 | let bad_use = use_uncontended_ret contended_ret "hello" ^^^^^^^^^^^^^ -Error: This expression has type string -> string @ contended - but an expression was expected of type 'a -> 'b +Error: This expression has type "string -> string @ contended" + but an expression was expected of type "'a -> 'b" |}] (* @@ -501,8 +501,8 @@ let result = use_global bar 1. 2. Line 1, characters 24-27: 1 | let result = use_global bar 1. 2. ^^^ -Error: This expression has type local_ float -> local_ float -> unit - but an expression was expected of type local_ 'a -> ('b -> 'c) +Error: This expression has type "local_ float -> local_ float -> unit" + but an expression was expected of type "local_ 'a -> ('b -> 'c)" |}] let use_portable_arg (f : (_ -> _) @ portable -> _) g = f g @@ -527,8 +527,8 @@ val portable_arg : (unit -> 'a) @ portable -> 'a = Line 3, characters 34-46: 3 | let bad_use = use_nonportable_arg portable_arg (fun () -> ()) ^^^^^^^^^^^^ -Error: This expression has type (unit -> 'a) @ portable -> 'a - but an expression was expected of type ('b -> 'c) -> 'd +Error: This expression has type "(unit -> 'a) @ portable -> 'a" + but an expression was expected of type "('b -> 'c) -> 'd" |}] let use_uncontended_arg (f : _ @ uncontended -> _) x = f x @@ -549,6 +549,6 @@ val uncontended_arg : 'a -> unit = Line 3, characters 32-47: 3 | let bad_use = use_contended_arg uncontended_arg () ^^^^^^^^^^^^^^^ -Error: This expression has type 'a -> unit - but an expression was expected of type 'b @ contended -> 'c +Error: This expression has type "'a -> unit" + but an expression was expected of type "'b @ contended -> 'c" |}] diff --git a/ocaml/testsuite/tests/typing-modes/mutable.ml b/ocaml/testsuite/tests/typing-modes/mutable.ml index 2b32d8b6e76..9da90679c09 100644 --- a/ocaml/testsuite/tests/typing-modes/mutable.ml +++ b/ocaml/testsuite/tests/typing-modes/mutable.ml @@ -100,13 +100,7 @@ let foo (r @ unique) = (r.s : _ @@ unique) Line 1, characters 24-27: 1 | let foo (r @ unique) = (r.s : _ @@ unique) ^^^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] module M : sig diff --git a/ocaml/testsuite/tests/typing-unique/unique.ml b/ocaml/testsuite/tests/typing-unique/unique.ml index 1f4a8f29210..9347b46f2e1 100644 --- a/ocaml/testsuite/tests/typing-unique/unique.ml +++ b/ocaml/testsuite/tests/typing-unique/unique.ml @@ -141,13 +141,7 @@ let f () = Line 4, characters 12-13: 4 | unique_ k ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". Hint: This identifier cannot be used uniquely, because it was defined outside of the for-loop. |}] @@ -163,13 +157,7 @@ let f = Line 5, characters 14-15: 5 | let _ = g a in () ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". Hint: This identifier cannot be used uniquely, because it was defined outside of the for-loop. |}] @@ -249,13 +237,7 @@ let foo y = unique_ x Line 1, characters 20-21: 1 | let foo y = unique_ x ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] @@ -320,33 +302,15 @@ let higher_order3 (f : 'a -> 'b) (unique_ x : 'a) = unique_ f x Line 1, characters 60-63: 1 | let higher_order3 (f : 'a -> 'b) (unique_ x : 'a) = unique_ f x ^^^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] let higher_order4 (f : unique_ 'a -> 'b) (x : 'a) = f (aliased_id x) [%%expect{| -<<<<<<< HEAD -Line 1, characters 54-67: -1 | let higher_order4 (f : unique_ 'a -> 'b) (x : 'a) = f (shared_id x) - ^^^^^^^^^^^^^ -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Line 1, characters 54-67: -1 | let higher_order4 (f : unique_ 'a -> 'b) (x : 'a) = f (shared_id x) - ^^^^^^^^^^^^^ -Error: This value is shared but expected to be unique. -======= Line 1, characters 54-68: 1 | let higher_order4 (f : unique_ 'a -> 'b) (x : 'a) = f (aliased_id x) ^^^^^^^^^^^^^^ -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] let higher_order5 (unique_ x) = let f (unique_ x) = unique_ x in higher_order f x @@ -389,22 +353,10 @@ val inf2 : bool -> unique_ float -> float = let inf3 : bool -> float -> unique_ float -> float = fun b y x -> let _ = aliased_id y in let unique_ z = if b then x else y in z [%%expect{| -<<<<<<< HEAD -Line 2, characters 58-59: -2 | let _ = shared_id y in let unique_ z = if b then x else y in z - ^ -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Line 2, characters 58-59: -2 | let _ = shared_id y in let unique_ z = if b then x else y in z - ^ -Error: This value is shared but expected to be unique. -======= Line 2, characters 59-60: 2 | let _ = aliased_id y in let unique_ z = if b then x else y in z ^ -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] let inf4 (b : bool) (y : float) (unique_ x : float) = @@ -636,38 +588,6 @@ Error: This expression has type "int" but an expression was expected of type "string" |}] -<<<<<<< HEAD - -let foo () = - let unique_ _bar : int -> int -> int = - ((fun y z -> z) : int -> unique_ (int -> int)) in - () -[%%expect{| -Line 3, characters 4-50: -3 | ((fun y z -> z) : int -> unique_ (int -> int)) in - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This expression has type "int -> unique_ (int -> int)" - but an expression was expected of type "int -> int -> int" -|}] - - -||||||| caebc8adff - -let foo () = - let unique_ _bar : int -> int -> int = - ((fun y z -> z) : int -> unique_ (int -> int)) in - () -[%%expect{| -Line 3, characters 4-50: -3 | ((fun y z -> z) : int -> unique_ (int -> int)) in - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This expression has type int -> unique_ (int -> int) - but an expression was expected of type int -> int -> int -|}] - - -======= ->>>>>>> flambda-backend/main let return_local : local_ 'a -> local_ 'a = fun x -> x let return_global : local_ 'a -> int = fun x -> 0 [%%expect{| diff --git a/ocaml/testsuite/tests/typing-unique/unique_analysis.ml b/ocaml/testsuite/tests/typing-unique/unique_analysis.ml index b177dad56e9..f6c55c0a1b7 100644 --- a/ocaml/testsuite/tests/typing-unique/unique_analysis.ml +++ b/ocaml/testsuite/tests/typing-unique/unique_analysis.ml @@ -188,13 +188,7 @@ let or_patterns1 : unique_ float list -> float list -> float = Line 3, characters 37-38: 3 | | z :: _, _ | _, z :: _ -> unique_ z ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] let or_patterns2 : float list -> unique_ float list -> float = @@ -205,13 +199,7 @@ let or_patterns2 : float list -> unique_ float list -> float = Line 3, characters 37-38: 3 | | z :: _, _ | _, z :: _ -> unique_ z ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". |}] let or_patterns3 p = diff --git a/ocaml/testsuite/tests/typing-unique/unique_mod_class.ml b/ocaml/testsuite/tests/typing-unique/unique_mod_class.ml index fe5ea8d24c1..45be4792830 100644 --- a/ocaml/testsuite/tests/typing-unique/unique_mod_class.ml +++ b/ocaml/testsuite/tests/typing-unique/unique_mod_class.ml @@ -19,13 +19,7 @@ val unique_id : unique_ 'a -> unit = Line 8, characters 20-21: 8 | val bar = unique_ x ^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". -||||||| caebc8adff -Error: This value is shared but expected to be unique. -======= -Error: This value is aliased but expected to be unique. ->>>>>>> flambda-backend/main +Error: This value is "aliased" but expected to be "unique". Hint: This identifier cannot be used uniquely, because it is defined in a class. |}] @@ -155,13 +149,5 @@ module M : sig val foo : string end Line 7, characters 12-17: 7 | unique_id M.foo ^^^^^ -<<<<<<< HEAD -Error: This value is "shared" but expected to be "unique". +Error: This value is "aliased" but expected to be "unique". |}] -||||||| caebc8adff -Error: This value is shared but expected to be unique. -|}] -======= -Error: This value is aliased but expected to be unique. -|}] ->>>>>>> flambda-backend/main diff --git a/ocaml/testsuite/tests/typing-unique/unique_typedecl.ml b/ocaml/testsuite/tests/typing-unique/unique_typedecl.ml index 386252548c3..88b16007978 100644 --- a/ocaml/testsuite/tests/typing-unique/unique_typedecl.ml +++ b/ocaml/testsuite/tests/typing-unique/unique_typedecl.ml @@ -65,16 +65,6 @@ Line 1, characters 42-89: 1 | type distinct_sarg_sret = unit constraint unique_ int -> int = unique_ int -> unique_ int ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The type constraints are not consistent. -<<<<<<< HEAD Type "unique_ int -> int" is not compatible with type "unique_ int -> unique_ int" |}] -||||||| caebc8adff - Type unique_ int -> int is not compatible with type - unique_ int -> unique_ int -|}] -======= - Type unique_ int -> int is not compatible with type - unique_ int -> unique_ int -|}] ->>>>>>> flambda-backend/main