Merge remote-tracking branch 'upstream-flambda-backend/main' into tes…

…t-vectorizer-always-on-base

bytecomp/bytegen.ml

@@ -158,6 +158,7 @@ let preserve_tailcall_for_prim = function
   | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _
   | Pufloatfield _ | Psetufloatfield _ | Pmixedfield _ | Psetmixedfield _
   | Pmake_unboxed_product _ | Punboxed_product_field _
+  | Parray_element_size_in_bytes _
   | Pccall _ | Praise _ | Pnot | Pnegint | Paddint | Psubint | Pmulint
   | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint
   | Pasrint | Pintcomp _ | Poffsetint _ | Poffsetref _ | Pintoffloat _
@@ -415,6 +416,8 @@ let comp_primitive stack_info p sz args =
   | Pcompare_bints bi -> comp_bint_primitive bi "compare" args
   | Pfield (n, _ptr, _sem) -> Kgetfield n
   | Punboxed_product_field (n, _layouts) -> Kgetfield n
+  | Parray_element_size_in_bytes _array_kind ->
+      Kconst (Const_base (Const_int (Sys.word_size / 8)))
   | Pfield_computed _sem -> Kgetvectitem
   | Psetfield(n, _ptr, _init) -> Ksetfield n
   | Psetfield_computed(_ptr, _init) -> Ksetvectitem
@@ -685,7 +688,10 @@ let comp_primitive stack_info p sz args =
         "Preinterpret_unboxed_int64_as_tagged_int63 can only be used on 64-bit \
          targets";
     Kccall("caml_reinterpret_unboxed_int64_as_tagged_int63", 1)
-  | Pmakearray_dynamic(kind, locality) ->
+  | Pmakearray_dynamic(kind, locality, With_initializer) ->
+    if List.compare_length_with args 2 <> 0 then
+      fatal_error "Bytegen.comp_primitive: Pmakearray_dynamic takes two \
+        arguments for [With_initializer]";
     (* CR layouts v4.0: This is "wrong" for unboxed types. It should construct
        blocks that can't be marshalled. We've decided to ignore that problem in
        the short term, as it's unlikely to cause issues - see the internal arrays
@@ -701,15 +707,18 @@ let comp_primitive stack_info p sz args =
     | Alloc_heap -> Kccall("caml_make_vect", 2)
     | Alloc_local -> Kccall("caml_make_local_vect", 2)
     end
-  | Parrayblit(kind) ->
-    begin match kind with
+  | Parrayblit { src_mutability = _; dst_array_set_kind } ->
+    begin match dst_array_set_kind with
     | Punboxedvectorarray_set _ ->
       fatal_error "SIMD is not supported in bytecode mode."
     | Pgenarray_set _ | Pintarray_set | Paddrarray_set _
     | Punboxedintarray_set _ | Pfloatarray_set | Punboxedfloatarray_set _
     | Pgcscannableproductarray_set _ | Pgcignorableproductarray_set _ -> ()
     end;
     Kccall("caml_array_blit", 5)
+  | Pmakearray_dynamic(_, _, Uninitialized) ->
+    Misc.fatal_error "Pmakearray_dynamic Uninitialized should have been \
+      translated to Pmakearray_dynamic Initialized earlier on"
   (* The cases below are handled in [comp_expr] before the [comp_primitive] call
      (in the order in which they appear below),
      so they should never be reached in this function. *)
@@ -1011,6 +1020,54 @@ and comp_expr stack_info env exp sz cont =
           (Kreperformterm(sz + nargs) :: discard_dead_code cont)
       else
         fatal_error "Reperform used in non-tail position"
+  | Lprim (Pmakearray_dynamic (kind, locality, Uninitialized), [len], loc) ->
+      (* Use a dummy initializer to implement the "uninitialized" primitive *)
+      let init =
+        match kind with
+        | Pgenarray | Paddrarray | Pintarray | Pfloatarray
+        | Pgcscannableproductarray _ ->
+            Misc.fatal_errorf "Array kind %s should have been ruled out by \
+                the frontend for %%makearray_dynamic_uninit"
+              (Printlambda.array_kind kind)
+        | Punboxedfloatarray Unboxed_float32 ->
+            Lconst (Const_base (Const_float32 "0.0"))
+        | Punboxedfloatarray Unboxed_float64 ->
+            Lconst (Const_base (Const_float "0.0"))
+        | Punboxedintarray Unboxed_int32 ->
+            Lconst (Const_base (Const_int32 0l))
+        | Punboxedintarray Unboxed_int64 ->
+            Lconst (Const_base (Const_int64 0L))
+        | Punboxedintarray Unboxed_nativeint ->
+            Lconst (Const_base (Const_nativeint 0n))
+        | Punboxedvectorarray _ ->
+            fatal_error "SIMD is not supported in bytecode mode."
+        | Pgcignorableproductarray ignorables ->
+            let rec convert_ignorable
+                  (ign : Lambda.ignorable_product_element_kind) =
+              match ign with
+              | Pint_ignorable -> Lconst (Const_base (Const_int 0))
+              | Punboxedfloat_ignorable Unboxed_float32 ->
+                Lconst (Const_base (Const_float32 "0.0"))
+              | Punboxedfloat_ignorable Unboxed_float64 ->
+                Lconst (Const_base (Const_float "0.0"))
+              | Punboxedint_ignorable Unboxed_int32 ->
+                Lconst (Const_base (Const_int32 0l))
+              | Punboxedint_ignorable Unboxed_int64 ->
+                Lconst (Const_base (Const_int64 0L))
+              | Punboxedint_ignorable Unboxed_nativeint ->
+                Lconst (Const_base (Const_nativeint 0n))
+              | Pproduct_ignorable ignorables ->
+                  let fields = List.map convert_ignorable ignorables in
+                  Lprim (Pmakeblock (0, Immutable, None, alloc_heap), fields,
+                    loc)
+            in
+            convert_ignorable (Pproduct_ignorable ignorables)
+      in
+      comp_expr stack_info env
+        (Lprim (Pmakearray_dynamic (kind, locality, With_initializer),
+          [len; init], loc)) sz cont
+  | Lprim (Pmakearray_dynamic (_, _, Uninitialized), _, _loc) ->
+      Misc.fatal_error "Pmakearray_dynamic takes one arg when [Uninitialized]"
   | Lprim (Pduparray (kind, mutability),
            [Lprim (Pmakearray (kind',_,m),args,_)], loc) ->
       assert (kind = kind');

jane/doc/extensions/modes/reference.md

@@ -0,0 +1,42 @@
+The goal of this document is to be a reasonably complete reference to the mode system in
+OCaml.
+
+<!-- CR zqian: For a gentler introduction, see [the introduction](intro.md). -->
+
+The mode system in the compiler tracks various properties of values, so that certain
+performance-enhancing operations can be performed safely. For example:
+- Locality tracks escaping. See [the local allocations reference](../local/reference.md)
+- Uniqueness and linearity tracks aliasing. See [the uniqueness reference](../uniqueness/reference.md)
+- Portability and contention tracks inter-thread sharing.
+    <!-- CR zqian: reference for portability and contention -->
+
+# Lazy
+`lazy e` contains a thunk that evaluates `e`, as well as a mutable cell to store the
+result of `e`. Upon construction, the mode of `lazy e` cannot be stronger than `e`. For
+example, if `e` is `nonportable`, then `lazy e` cannot be `portable`. Upon destruction
+(forcing a lazy value), the result cannot be stronger than the mode of lazy value. For
+example, forcing a `nonportable` lazy value cannot give a `portable` result. Additionally,
+forcing a lazy value involves accessing the mutable cell and thus requires the lazy value
+to be `uncontended`.
+
+Currently, the above rules don't apply to the locality axis, because both the result and
+the lazy value are heap-allocated, so they are always `global`.
+
+Additionally, upon construction, the comonadic fragment of `lazy e` cannot be stronger
+than the thunk. The thunk is checked as `fun () -> e`, potentially closing over variables,
+which weakens its comonadic fragment. This rule doesn't apply to several axes:
+- The thunk is always heap-allocated so always `global`.
+- Since the thunk is only evaluated if the lazy value is `uncontended`, one can construct
+a lazy value at `portable` even if the thunk is `nonportable` (e.g., closing over
+`uncontended` or `nonportable` values). For example, the following is allowed:
+```ocaml
+let r = ref 0 in
+let l @ portable = lazy (r := 42) in
+```
+- Since the thunk runs at most once even if the lazy value is forced multiple times, one
+can construct the lazy value at `many` even if the thunk is `once` (e.g., closing over
+`unique` or `once` values). For example, the following is allowed:
+```ocaml
+let r = { x = 0 } in
+let l @ many = lazy (overwrite_ r with { x = 42 })
+```

lambda/lambda.ml

@@ -43,6 +43,10 @@ type field_read_semantics =
   | Reads_agree
   | Reads_vary
 
+type has_initializer =
+  | With_initializer
+  | Uninitialized
+
 include (struct
 
   type locality_mode =
@@ -149,6 +153,7 @@ type primitive =
   (* Unboxed products *)
   | Pmake_unboxed_product of layout list
   | Punboxed_product_field of int * layout list
+  | Parray_element_size_in_bytes of array_kind
   (* Context switches *)
   | Prunstack
   | Pperform
@@ -189,9 +194,12 @@ type primitive =
   | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
   (* Array operations *)
   | Pmakearray of array_kind * mutable_flag * locality_mode
-  | Pmakearray_dynamic of array_kind * locality_mode
+  | Pmakearray_dynamic of array_kind * locality_mode * has_initializer
   | Pduparray of array_kind * mutable_flag
-  | Parrayblit of array_set_kind (* Kind of the dest array. *)
+  | Parrayblit of {
+      src_mutability : mutable_flag;
+      dst_array_set_kind : array_set_kind;
+    }
   | Parraylength of array_kind
   | Parrayrefu of array_ref_kind * array_index_kind * mutable_flag
   | Parraysetu of array_set_kind * array_index_kind
@@ -944,6 +952,10 @@ let lfunction ~kind ~params ~return ~body ~attr ~loc ~mode ~ret_mode ~region =
 
 let lambda_unit = Lconst const_unit
 
+let of_bool = function
+  | true -> Lconst (const_int 1)
+  | false -> Lconst (const_int 0)
+
 (* CR vlaviron: review the following cases *)
 let non_null_value raw_kind =
   Pvalue { raw_kind; nullable = Non_nullable }
@@ -1819,7 +1831,7 @@ let primitive_may_allocate : primitive -> locality_mode option = function
   | Pstringlength | Pstringrefu  | Pstringrefs
   | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets -> None
   | Pmakearray (_, _, m) -> Some m
-  | Pmakearray_dynamic (_, m) -> Some m
+  | Pmakearray_dynamic (_, m, _) -> Some m
   | Pduparray _ -> Some alloc_heap
   | Parraylength _ -> None
   | Parrayblit _
@@ -1928,7 +1940,8 @@ let primitive_may_allocate : primitive -> locality_mode option = function
   | Patomic_cas
   | Patomic_fetch_add
   | Pdls_get
-  | Preinterpret_unboxed_int64_as_tagged_int63 -> None
+  | Preinterpret_unboxed_int64_as_tagged_int63
+  | Parray_element_size_in_bytes _ -> None
   | Preinterpret_tagged_int63_as_unboxed_int64 ->
     if !Clflags.native_code then None
     else
@@ -2093,7 +2106,8 @@ let primitive_can_raise prim =
   | Patomic_cas | Patomic_fetch_add | Patomic_load _ -> false
   | Prunstack | Pperform | Presume | Preperform -> true (* XXX! *)
   | Pdls_get | Ppoll | Preinterpret_tagged_int63_as_unboxed_int64
-  | Preinterpret_unboxed_int64_as_tagged_int63 ->
+  | Preinterpret_unboxed_int64_as_tagged_int63
+  | Parray_element_size_in_bytes _ ->
     false
 
 let constant_layout: constant -> layout = function
@@ -2205,6 +2219,7 @@ let primitive_result_layout (p : primitive) =
   | Pfield _ | Pfield_computed _ -> layout_value_field
   | Punboxed_product_field (field, layouts) -> (Array.of_list layouts).(field)
   | Pmake_unboxed_product layouts -> layout_unboxed_product layouts
+  | Parray_element_size_in_bytes _ -> layout_int
   | Pfloatfield _ -> layout_boxed_float Boxed_float64
   | Pfloatoffloat32 _ -> layout_boxed_float Boxed_float64
   | Pfloat32offloat _ -> layout_boxed_float Boxed_float32
@@ -2388,6 +2403,21 @@ let array_set_kind mode = function
   | Pgcscannableproductarray kinds -> Pgcscannableproductarray_set (mode, kinds)
   | Pgcignorableproductarray kinds -> Pgcignorableproductarray_set kinds
 
+let array_ref_kind_of_array_set_kind (kind : array_set_kind) mode
+      : array_ref_kind =
+  match kind with
+  | Pintarray_set -> Pintarray_ref
+  | Punboxedfloatarray_set uf -> Punboxedfloatarray_ref uf
+  | Punboxedintarray_set ui -> Punboxedintarray_ref ui
+  | Punboxedvectorarray_set uv -> Punboxedvectorarray_ref uv
+  | Pgcscannableproductarray_set (_, scannables) ->
+    Pgcscannableproductarray_ref scannables
+  | Pgcignorableproductarray_set ignorables ->
+    Pgcignorableproductarray_ref ignorables
+  | Pgenarray_set _ -> Pgenarray_ref mode
+  | Paddrarray_set _ -> Paddrarray_ref
+  | Pfloatarray_set -> Pfloatarray_ref mode
+
 let may_allocate_in_region lam =
   (* loop_region raises, if the lambda might allocate in parent region *)
   let rec loop_region lam =
@@ -2479,3 +2509,47 @@ let rec try_to_find_location lam =
 
 let try_to_find_debuginfo lam =
   Debuginfo.from_location (try_to_find_location lam)
+
+(* The "count_initializers_*" functions count the number of individual
+   components in an initializer for the corresponding array kind _after_
+   unarization.  These are used to implement the "%array_element_size_in_bytes"
+   primitives for products, as each such component takes a full word in product
+   arrays. *)
+let rec count_initializers_scannable
+      (scannable : scannable_product_element_kind) =
+  match scannable with
+  | Pint_scannable | Paddr_scannable -> 1
+  | Pproduct_scannable scannables ->
+    List.fold_left
+      (fun acc scannable -> acc + count_initializers_scannable scannable)
+      0 scannables
+
+let rec count_initializers_ignorable
+    (ignorable : ignorable_product_element_kind) =
+  match ignorable with
+  | Pint_ignorable | Punboxedfloat_ignorable _ | Punboxedint_ignorable _ -> 1
+  | Pproduct_ignorable ignorables ->
+    List.fold_left
+      (fun acc ignorable -> acc + count_initializers_ignorable ignorable)
+      0 ignorables
+
+let count_initializers_array_kind (lambda_array_kind : array_kind) =
+  match lambda_array_kind with
+  | Pgenarray | Paddrarray | Pintarray | Pfloatarray | Punboxedfloatarray _
+  | Punboxedintarray _ | Punboxedvectorarray _ -> 1
+  | Pgcscannableproductarray scannables ->
+    List.fold_left
+      (fun acc scannable -> acc + count_initializers_scannable scannable)
+      0 scannables
+  | Pgcignorableproductarray ignorables ->
+    List.fold_left
+      (fun acc ignorable -> acc + count_initializers_ignorable ignorable)
+      0 ignorables
+
+let rec ignorable_product_element_kind_involves_int
+    (kind : ignorable_product_element_kind) =
+  match kind with
+  | Pint_ignorable -> true
+  | Punboxedfloat_ignorable _ | Punboxedint_ignorable _ -> false
+  | Pproduct_ignorable kinds ->
+    List.exists ignorable_product_element_kind_involves_int kinds

lambda/lambda.mli

@@ -74,6 +74,10 @@ type field_read_semantics =
   | Reads_agree
   | Reads_vary
 
+type has_initializer =
+  | With_initializer
+  | Uninitialized
+
 (* Tail calls can close their enclosing region early *)
 type region_close =
   | Rc_normal         (* do not close region, may TCO if in tail position *)
@@ -137,6 +141,7 @@ type primitive =
   | Pmake_unboxed_product of layout list
   | Punboxed_product_field of int * (layout list)
       (* the [layout list] is the layout of the whole product *)
+  | Parray_element_size_in_bytes of array_kind
   (* Context switches *)
   | Prunstack
   | Pperform
@@ -178,15 +183,21 @@ type primitive =
   | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
   (* Array operations *)
   | Pmakearray of array_kind * mutable_flag * locality_mode
-  | Pmakearray_dynamic of array_kind * locality_mode
+  | Pmakearray_dynamic of array_kind * locality_mode * has_initializer
+  (** For [Pmakearray_dynamic], if the array kind specifies an unboxed
+      product, the float array optimization will never apply. *)
   | Pduparray of array_kind * mutable_flag
   (** For [Pduparray], the argument must be an immutable array.
       The arguments of [Pduparray] give the kind and mutability of the
       array being *produced* by the duplication. *)
-  | Parrayblit of array_set_kind
+  | Parrayblit of {
+      src_mutability : mutable_flag;
+      dst_array_set_kind : array_set_kind;
+    }
   (** For [Parrayblit], we record the [array_set_kind] of the destination
       array. We check that the source array has the same shape, but do not
-      need to know anything about its locality. *)
+      need to know anything about its locality. We do however request the
+      mutability of the source array. *)
   | Parraylength of array_kind
   | Parrayrefu of array_ref_kind * array_index_kind * mutable_flag
   | Parraysetu of array_set_kind * array_index_kind
@@ -914,6 +925,8 @@ val const_unit: structured_constant
 val const_int : int -> structured_constant
 val lambda_unit: lambda
 
+val of_bool : bool -> lambda
+
 val layout_unit : layout
 val layout_int : layout
 val layout_array : array_kind -> layout
@@ -1158,6 +1171,11 @@ val array_ref_kind : locality_mode -> array_kind -> array_ref_kind
 (** The mode will be discarded if unnecessary for the given [array_kind] *)
 val array_set_kind : modify_mode -> array_kind -> array_set_kind
 
+(** Any mode information in the given [array_set_kind] is ignored.  Any mode
+    in the return value always comes from the [locality_mode] parameter. *)
+val array_ref_kind_of_array_set_kind
+  : array_set_kind -> locality_mode -> array_ref_kind
+
 (* Returns true if the given lambda can allocate on the local stack *)
 val may_allocate_in_region : lambda -> bool
 
@@ -1173,3 +1191,7 @@ val try_to_find_location : lambda -> scoped_location
 val try_to_find_debuginfo : lambda -> Debuginfo.t
 
 val primitive_can_raise : primitive -> bool
+
+val count_initializers_array_kind : array_kind -> int
+val ignorable_product_element_kind_involves_int :
+  ignorable_product_element_kind -> bool