Squashed 'ocaml/' changes from 0b0aefb..ce76e02

ce76e02 flambda-backend: Bugfix for type_application (#746)
44f3afb flambda-backend: PR580 for main branch (#743)
b851eaa flambda-backend: Backport first part of ocaml/ocaml PR10498 (#737)
fafb4bd flambda-backend: Fix return mode for eta-expanded function in type_argument (#735)
c31f6c3 flambda-backend: Fix treatment of functions called [@nontail] (#725)
847781e flambda-backend: Fix build_upstream post-PR703 (#712)
bfcbbf8 flambda-backend: Extend Pblock value kind to handle variants (#703)
b2cab95 flambda-backend: Merge ocaml-jst
a6d6e0e flambda-backend: Merge ocaml-jst
88a4f63 flambda-backend: Use Pmakearray for immutable arrays (#699)
eeaa44b flambda-backend: Install an ocamldoc binary (#695)
48d322b flambda-backend: Ensure that GC is not invoked from bounds check failures (#681)
4370fa1 flambda-backend: Review changes of term directory (#602)
65a4566 flambda-backend: Add code coverage using bisect_ppx (#352)
63ab65f flambda-backend: Bugfix for primitive inclusion (#662)
7e3e0c8 flambda-backend: Fix inclusion checks for primitives (#661)
96c68f9 flambda-backend: Speed up linking by changing cmxa format (#607)
1829150 flambda-backend: Bugfix for Translmod.all_idents (#659)

git-subtree-dir: ocaml
git-subtree-split: ce76e02

Author: ccasin

.gitignore

@@ -55,6 +55,7 @@ _build
 /ocamlopt
 /ocamlopt.opt
 /ocamlnat
+/dirs-to-ignore.inc
 
 # specific files and patterns in sub-directories
 

asmcomp/cmm_helpers.ml

@@ -2002,7 +2002,7 @@ let send_function (arity, mode) =
   let cache = cache in
   let fun_name = send_function_name arity mode in
   let fun_args =
-    [obj, typ_val; tag, typ_int; cache, typ_val]
+    [obj, typ_val; tag, typ_int; cache, typ_addr]
     @ List.map (fun id -> (id, typ_val)) (List.tl args) in
   let fun_dbg = placeholder_fun_dbg ~human_name:fun_name in
   Cfunction

asmcomp/cmmgen.ml

@@ -711,7 +711,7 @@ and transl_catch env nfail ids body handler dbg =
          let strict =
            match kind with
            | Pfloatval | Pboxedintval _ -> false
-           | Pintval | Pgenval | Pblock _ | Parrayval _ -> true
+           | Pintval | Pgenval | Pvariant _ | Parrayval _ -> true
          in
          u := join_unboxed_number_kind ~strict !u
              (is_unboxed_number_cmm ~strict c)
@@ -1179,7 +1179,7 @@ and transl_let env str kind id exp transl_body =
            we do it only if this indeed allows us to get rid of
            some allocations in the bound expression. *)
         is_unboxed_number_cmm ~strict:false cexp
-    | _, (Pgenval | Pblock _ | Parrayval _) ->
+    | _, (Pgenval | Pvariant _ | Parrayval _) ->
         (* Here we don't know statically that the bound expression
            evaluates to an unboxable number type.  We need to be stricter
            and ensure that all possible branches in the expression

dune

@@ -121,7 +121,9 @@
  (libraries ocamlbytecomp ocamlcommon)
  (modules main_native))
 
-(data_only_dirs yacc)
+; Disabled since there can be only one (data_only_dirs) declaration
+;(data_only_dirs yacc)
+(include dirs-to-ignore.inc)
 
 (rule
  (deps (source_tree yacc))

lambda/lambda.ml

@@ -220,7 +220,10 @@ and float_comparison =
 
 and value_kind =
     Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
-  | Pblock of { tag : int; fields : value_kind list }
+  | Pvariant of {
+      consts : int list;
+      non_consts : (int * value_kind list) list;
+    }
   | Parrayval of array_kind
 
 and block_shape =
@@ -273,11 +276,20 @@ let rec equal_value_kind x y =
   | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2
   | Pintval, Pintval -> true
   | Parrayval elt_kind1, Parrayval elt_kind2 -> elt_kind1 = elt_kind2
-  | Pblock { tag = tag1; fields = fields1 },
-    Pblock { tag = tag2; fields = fields2 } ->
-    tag1 = tag2 && List.length fields1 = List.length fields2 &&
-    List.for_all2 equal_value_kind fields1 fields2
-  | (Pgenval | Pfloatval | Pboxedintval _ | Pintval | Pblock _
+  | Pvariant { consts = consts1; non_consts = non_consts1; },
+    Pvariant { consts = consts2; non_consts = non_consts2; } ->
+    let consts1 = List.sort Int.compare consts1 in
+    let consts2 = List.sort Int.compare consts2 in
+    let compare_by_tag (tag1, _) (tag2, _) = Int.compare tag1 tag2 in
+    let non_consts1 = List.sort compare_by_tag non_consts1 in
+    let non_consts2 = List.sort compare_by_tag non_consts2 in
+    List.equal Int.equal consts1 consts2
+      && List.equal (fun (tag1, fields1) (tag2, fields2) ->
+             Int.equal tag1 tag2
+             && List.length fields1 = List.length fields2
+             && List.for_all2 equal_value_kind fields1 fields2)
+           non_consts1 non_consts2
+  | (Pgenval | Pfloatval | Pboxedintval _ | Pintval | Pvariant _
       | Parrayval _), _ -> false
 
 

lambda/lambda.mli

@@ -193,7 +193,13 @@ and array_kind =
 
 and value_kind =
     Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
-  | Pblock of { tag : int; fields : value_kind list }
+  | Pvariant of {
+      consts : int list;
+      non_consts : (int * value_kind list) list;
+      (** [non_consts] must be non-empty.  For constant variants [Pintval]
+          must be used.  This causes a small loss of precision but it is not
+          expected to be significant. *)
+    }
   | Parrayval of array_kind
 
 and block_shape =

lambda/printlambda.ml

@@ -63,27 +63,37 @@ let boxed_integer_name = function
   | Pint32 -> "int32"
   | Pint64 -> "int64"
 
+let variant_kind print_contents ppf ~consts ~non_consts =
+  fprintf ppf "@[<hov 1>[(consts (%a))@ (non_consts (%a))]@]"
+    (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_int)
+    consts
+    (Format.pp_print_list ~pp_sep:Format.pp_print_space
+      (fun ppf (tag, fields) ->
+        fprintf ppf "@[<hov 1>[%d:@ %a]@]"
+          tag
+          (Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
+            print_contents)
+          fields
+      ))
+    non_consts
+
 let rec value_kind ppf = function
   | Pgenval -> ()
   | Pintval -> fprintf ppf "[int]"
   | Pfloatval -> fprintf ppf "[float]"
   | Parrayval elt_kind -> fprintf ppf "[%sarray]" (array_kind elt_kind)
   | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi)
-  | Pblock { tag; fields } ->
-    fprintf ppf "[%d: %a]" tag
-      (Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
-        value_kind') fields
+  | Pvariant { consts; non_consts; } ->
+    variant_kind value_kind' ppf ~consts ~non_consts
 
 and value_kind' ppf = function
   | Pgenval -> fprintf ppf "*"
   | Pintval -> fprintf ppf "[int]"
   | Pfloatval -> fprintf ppf "[float]"
   | Parrayval elt_kind -> fprintf ppf "[%sarray]" (array_kind elt_kind)
   | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi)
-  | Pblock { tag; fields } ->
-    fprintf ppf "[%d: %a]" tag
-      (Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
-        value_kind') fields
+  | Pvariant { consts; non_consts; } ->
+    variant_kind value_kind' ppf ~consts ~non_consts
 
 let return_kind ppf (mode, kind) =
   let smode = alloc_mode mode in
@@ -95,21 +105,27 @@ let return_kind ppf (mode, kind) =
   | Parrayval elt_kind ->
      fprintf ppf ": %s%sarray@ " smode (array_kind elt_kind)
   | Pboxedintval bi -> fprintf ppf ": %s%s@ " smode (boxed_integer_name bi)
-  | Pblock { tag; fields } ->
-    fprintf ppf ": %s[%d: %a]@ " smode tag
-      (Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
-        value_kind') fields
+  | Pvariant { consts; non_consts; } ->
+    variant_kind value_kind' ppf ~consts ~non_consts
 
 let field_kind ppf = function
   | Pgenval -> pp_print_string ppf "*"
   | Pintval -> pp_print_string ppf "int"
   | Pfloatval -> pp_print_string ppf "float"
   | Parrayval elt_kind -> fprintf ppf "%s-array" (array_kind elt_kind)
   | Pboxedintval bi -> pp_print_string ppf (boxed_integer_name bi)
-  | Pblock { tag; fields } ->
-    fprintf ppf "[%d: %a]" tag
-      (Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
-        value_kind') fields
+  | Pvariant { consts; non_consts; } ->
+    fprintf ppf "@[<hov 1>[(consts (%a))@ (non_consts (%a))]@]"
+      (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_int)
+      consts
+      (Format.pp_print_list ~pp_sep:Format.pp_print_space
+        (fun ppf (tag, fields) ->
+          fprintf ppf "@[<hov 1>[%d:@ %a]@]"
+            tag
+            (Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
+              value_kind') fields
+        ))
+      non_consts
 
 let alloc_kind = function
   | Alloc_heap -> ""

lambda/printlambda.mli

@@ -24,6 +24,9 @@ val lambda: formatter -> lambda -> unit
 val program: formatter -> program -> unit
 val primitive: formatter -> primitive -> unit
 val name_of_primitive : primitive -> string
+val variant_kind : (formatter -> value_kind -> unit) ->
+  formatter -> consts:int list -> non_consts:(int * value_kind list) list ->
+  unit
 val value_kind : formatter -> value_kind -> unit
 val value_kind' : formatter -> value_kind -> unit
 val block_shape : formatter -> value_kind list option -> unit

lambda/translcore.ml

@@ -299,7 +299,7 @@ let rec iter_exn_names f pat =
 let transl_ident loc env ty path desc kind =
   match desc.val_kind, kind with
   | Val_prim p, Id_prim pmode ->
-      let poly_mode = transl_alloc_mode pmode in
+      let poly_mode = Option.map transl_alloc_mode pmode in
       Translprim.transl_primitive loc p env ty ~poly_mode (Some path)
   | Val_anc _, Id_value ->
       raise(Error(to_location loc, Free_super_var))
@@ -374,7 +374,7 @@ and transl_exp0 ~in_new_scope ~scopes e =
         if extra_args = [] then transl_apply_position pos
         else Rc_normal
       in
-      let prim_mode = transl_alloc_mode pmode in
+      let prim_mode = Option.map transl_alloc_mode pmode in
       let lam =
         Translprim.transl_primitive_application
           (of_location ~scopes e.exp_loc) p e.exp_env prim_type prim_mode
@@ -557,12 +557,16 @@ and transl_exp0 ~in_new_scope ~scopes e =
                    of_location ~scopes e.exp_loc)
         | cl ->
             let imm_array =
-              match kind with
-              | Paddrarray | Pintarray ->
+              if Config.flambda2 then
+                Lprim (Pmakearray (kind, Immutable, mode), ll,
+                       of_location ~scopes e.exp_loc)
+              else
+                match kind with
+                | Paddrarray | Pintarray ->
                   Lconst(Const_block(0, cl))
-              | Pfloatarray ->
+                | Pfloatarray ->
                   Lconst(Const_float_array(List.map extract_float cl))
-              | Pgenarray ->
+                | Pgenarray ->
                   raise Not_constant    (* can this really happen? *)
             in
             Lprim (Pduparray (kind, Mutable), [imm_array],

lambda/translmod.ml

@@ -97,7 +97,7 @@ let rec apply_coercion loc strict restr arg =
       let carg = apply_coercion loc Alias cc_arg (Lvar param) in
       apply_coercion_result loc strict arg [param, Pgenval] [carg] cc_res
   | Tcoerce_primitive { pc_desc; pc_env; pc_type; pc_poly_mode } ->
-      let poly_mode = Translcore.transl_alloc_mode pc_poly_mode in
+      let poly_mode = Option.map Translcore.transl_alloc_mode pc_poly_mode in
       Translprim.transl_primitive loc pc_desc pc_env pc_type ~poly_mode None
   | Tcoerce_alias (env, path, cc) ->
       let lam = transl_module_path loc env path in
@@ -613,7 +613,8 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function
                       | Tcoerce_primitive p ->
                           let loc = of_location ~scopes p.pc_loc in
                           let poly_mode =
-                            Translcore.transl_alloc_mode p.pc_poly_mode
+                            Option.map
+                              Translcore.transl_alloc_mode p.pc_poly_mode
                           in
                           Translprim.transl_primitive
                             loc p.pc_desc p.pc_env p.pc_type ~poly_mode None
@@ -987,8 +988,9 @@ and all_idents = function
     | Tstr_class_type _ -> all_idents rem
 
     | Tstr_include{incl_type; incl_mod={mod_desc =
-                             Tmod_constraint ({mod_desc = Tmod_structure str},
-                                              _, _, _)}} ->
+                              ( Tmod_constraint ({mod_desc = Tmod_structure str},
+                                              _, _, _)
+                              | Tmod_structure str ) }} ->
         bound_value_identifiers incl_type
         @ all_idents str.str_items
         @ all_idents rem
@@ -1038,7 +1040,7 @@ let field_of_str loc str =
   fun (pos, cc) ->
     match cc with
     | Tcoerce_primitive { pc_desc; pc_env; pc_type; pc_poly_mode } ->
-        let poly_mode = Translcore.transl_alloc_mode pc_poly_mode in
+        let poly_mode = Option.map Translcore.transl_alloc_mode pc_poly_mode in
         Translprim.transl_primitive loc pc_desc pc_env pc_type ~poly_mode None
     | Tcoerce_alias (env, path, cc) ->
         let lam = transl_module_path loc env path in
@@ -1379,7 +1381,9 @@ let transl_store_structure ~scopes glob map prims aliases str =
     List.fold_right (add_ident may_coerce) idlist subst
 
   and store_primitive (pos, prim) cont =
-    let poly_mode = Translcore.transl_alloc_mode prim.pc_poly_mode in
+    let poly_mode =
+      Option.map Translcore.transl_alloc_mode prim.pc_poly_mode
+    in
     Lsequence(Lprim(mod_setfield pos,
                     [Lprim(Pgetglobal glob, [], Loc_unknown);
                      Translprim.transl_primitive Loc_unknown

lambda/translprim.ml

@@ -112,7 +112,10 @@ let prim_sys_argv =
 let to_alloc_mode ~poly = function
   | Prim_global, _ -> alloc_heap
   | Prim_local, _ -> alloc_local
-  | Prim_poly, _ -> poly
+  | Prim_poly, _ ->
+    match poly with
+    | None -> assert false
+    | Some mode -> mode
 
 let lookup_primitive loc poly pos p =
   let mode = to_alloc_mode ~poly p.prim_native_repr_res in
@@ -714,8 +717,8 @@ let lambda_of_prim prim_name prim loc args arg_exps =
 let check_primitive_arity loc p =
   let mode =
     match p.prim_native_repr_res with
-    | Prim_global, _ | Prim_poly, _ -> alloc_heap
-    | Prim_local, _ -> alloc_local
+    | Prim_global, _ | Prim_poly, _ -> Some alloc_heap
+    | Prim_local, _ -> Some alloc_local
   in
   let prim = lookup_primitive loc mode Rc_normal p in
   let ok =

lambda/translprim.mli

@@ -35,13 +35,13 @@ val check_primitive_arity :
 val transl_primitive :
   Lambda.scoped_location -> Primitive.description -> Env.t ->
   Types.type_expr ->
-  poly_mode:Lambda.alloc_mode ->
+  poly_mode:Lambda.alloc_mode option ->
   Path.t option ->
   Lambda.lambda
 
 val transl_primitive_application :
   Lambda.scoped_location -> Primitive.description -> Env.t ->
-  Types.type_expr -> Lambda.alloc_mode -> Path.t ->
+  Types.type_expr -> Lambda.alloc_mode option -> Path.t ->
   Typedtree.expression option ->
   Lambda.lambda list -> Typedtree.expression list ->
   Lambda.region_close -> Lambda.lambda

middle_end/clambda_primitives.ml

@@ -135,7 +135,10 @@ and array_kind = Lambda.array_kind =
 and value_kind = Lambda.value_kind =
   (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *)
     Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
-  | Pblock of { tag : int; fields : value_kind list }
+  | Pvariant of {
+      consts : int list;
+      non_consts : (int * value_kind list) list;
+    }
   | Parrayval of array_kind
 
 and block_shape = Lambda.block_shape

middle_end/clambda_primitives.mli

@@ -138,7 +138,10 @@ and array_kind = Lambda.array_kind =
 and value_kind = Lambda.value_kind =
   (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *)
     Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
-  | Pblock of { tag : int; fields : value_kind list }
+  | Pvariant of {
+      consts : int list;
+      non_consts : (int * value_kind list) list;
+    }
   | Parrayval of array_kind
 
 and block_shape = Lambda.block_shape

middle_end/printclambda.ml

@@ -24,23 +24,33 @@ let mutable_flag = function
   | Lambda.Mutable-> "[mut]"
   | Lambda.Immutable | Lambda.Immutable_unique -> ""
 
-let value_kind =
+let rec value_kind0 ppf kind =
   let open Lambda in
-  function
-  | Pgenval -> ""
-  | Pintval -> ":int"
-  | Pfloatval -> ":float"
-  | Parrayval Pgenarray -> ":genarray"
-  | Parrayval Pintarray -> ":intarray"
-  | Parrayval Pfloatarray -> ":floatarray"
-  | Parrayval Paddrarray -> ":addrarray"
-  | Pboxedintval Pnativeint -> ":nativeint"
-  | Pboxedintval Pint32 -> ":int32"
-  | Pboxedintval Pint64 -> ":int64"
-  | Pblock { tag; fields } ->
-    asprintf ":[%d: %a]" tag
-      (Format.pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
-         Printlambda.value_kind') fields
+  match kind with
+  | Pgenval -> Format.pp_print_string ppf ""
+  | Pintval -> Format.pp_print_string ppf ":int"
+  | Pfloatval -> Format.pp_print_string ppf ":float"
+  | Parrayval Pgenarray -> Format.pp_print_string ppf ":genarray"
+  | Parrayval Pintarray -> Format.pp_print_string ppf ":intarray"
+  | Parrayval Pfloatarray -> Format.pp_print_string ppf ":floatarray"
+  | Parrayval Paddrarray -> Format.pp_print_string ppf ":addrarray"
+  | Pboxedintval Pnativeint -> Format.pp_print_string ppf ":nativeint"
+  | Pboxedintval Pint32 -> Format.pp_print_string ppf ":int32"
+  | Pboxedintval Pint64 -> Format.pp_print_string ppf ":int64"
+  | Pvariant { consts; non_consts } ->
+    Format.fprintf ppf "@[<hov 1>[(consts (%a))@ (non_consts (%a))]@]"
+      (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_int)
+      consts
+      (Format.pp_print_list ~pp_sep:Format.pp_print_space
+          (fun ppf (tag, fields) ->
+            fprintf ppf "@[<hov 1>[%d:@ %a]@]" tag
+              (Format.pp_print_list
+                ~pp_sep:(fun ppf () -> fprintf ppf ",@ ")
+                value_kind0)
+              fields))
+      non_consts
+
+let value_kind kind = Format.asprintf "%a" value_kind0 kind
 
 let rec structured_constant ppf = function
   | Uconst_float x -> fprintf ppf "%F" x