Merge commit 'e6096b8f6c3211a83f7855bda3d820c2408257dd' into parallel_minor_gc_4_10

5 files changed, 103 insertions, 58 deletions

diff --git a/middle_end/compilenv.ml b/middle_end/compilenv.ml
index add4e90e57..247b069403 100644
--- a/middle_end/compilenv.ml
+++ b/middle_end/compilenv.ml
@@ -49,16 +49,18 @@ module CstMap =
        because it compares "0.0" and "-0.0" equal. *)
   end)
 
+module SymMap = Misc.Stdlib.String.Map
+
 type structured_constants =
   {
     strcst_shared: string CstMap.t;
-    strcst_all: (string * Clambda.ustructured_constant) list;
+    strcst_all: Clambda.ustructured_constant SymMap.t;
   }
 
 let structured_constants_empty  =
   {
     strcst_shared = CstMap.empty;
-    strcst_all = [];
+    strcst_all = SymMap.empty;
   }
 
 let structured_constants = ref structured_constants_empty
@@ -371,7 +373,7 @@ let new_structured_constant cst ~shared =
       structured_constants :=
         {
           strcst_shared = CstMap.add cst lbl strcst_shared;
-          strcst_all = (lbl, cst) :: strcst_all;
+          strcst_all = SymMap.add lbl cst strcst_all;
         };
       lbl
   else
@@ -379,7 +381,7 @@ let new_structured_constant cst ~shared =
     structured_constants :=
       {
         strcst_shared;
-        strcst_all = (lbl, cst) :: strcst_all;
+        strcst_all = SymMap.add lbl cst strcst_all;
       };
     lbl
 
@@ -389,6 +391,9 @@ let add_exported_constant s =
 let clear_structured_constants () =
   structured_constants := structured_constants_empty
 
+let structured_constant_of_symbol s =
+  SymMap.find_opt s (!structured_constants).strcst_all
+
 let structured_constants () =
   let provenance : Clambda.usymbol_provenance =
     { original_idents = [];
@@ -396,7 +401,8 @@ let structured_constants () =
         Path.Pident (Ident.create_persistent (current_unit_name ()));
     }
   in
-  List.map
+  SymMap.bindings (!structured_constants).strcst_all
+  |> List.map
     (fun (symbol, definition) ->
        {
          Clambda.symbol;
@@ -404,7 +410,6 @@ let structured_constants () =
          definition;
          provenance = Some provenance;
        })
-    (!structured_constants).strcst_all
 
 let closure_symbol fv =
   let compilation_unit = Closure_id.get_compilation_unit fv in
diff --git a/middle_end/compilenv.mli b/middle_end/compilenv.mli
index 569d51ea08..8f1ef284f0 100644
--- a/middle_end/compilenv.mli
+++ b/middle_end/compilenv.mli
@@ -117,6 +117,10 @@ val new_structured_constant:
 val structured_constants:
   unit -> Clambda.preallocated_constant list
 val clear_structured_constants: unit -> unit
+
+val structured_constant_of_symbol:
+  string -> Clambda.ustructured_constant option
+
 val add_exported_constant: string -> unit
         (* clambda-only *)
 type structured_constants
diff --git a/middle_end/flambda/build_export_info.ml b/middle_end/flambda/build_export_info.ml
index de25c7e704..8b778528fc 100644
--- a/middle_end/flambda/build_export_info.ml
+++ b/middle_end/flambda/build_export_info.ml
@@ -38,6 +38,8 @@ module Env : sig
 
   val new_unit_descr : t -> Export_id.t
 
+  val is_symbol_being_defined : t -> Symbol.t -> bool
+
   module Global : sig
     (* "Global" as in "without local variable bindings". *)
     type t
@@ -53,7 +55,7 @@ module Env : sig
 
   (** Creates a new environment, sharing the mapping from export IDs to
       export descriptions with the given global environment. *)
-  val empty_of_global : Global.t -> t
+  val empty_of_global : symbols_being_defined:Symbol.Set.t -> Global.t -> t
 end = struct
   let fresh_id () = Export_id.create (Compilenv.current_unit ())
 
@@ -93,13 +95,15 @@ end = struct
   type t =
     { var : Export_info.approx Variable.Map.t;
       sym : Export_id.t Symbol.Map.t;
+      symbols_being_defined : Symbol.Set.t;
       ex_table : Export_info.descr Export_id.Map.t ref;
       closure_table: Export_id.t Closure_id.Map.t ref;
     }
 
-  let empty_of_global (env : Global.t) =
+  let empty_of_global ~symbols_being_defined (env : Global.t) =
     { var = Variable.Map.empty;
       sym = env.sym;
+      symbols_being_defined;
       ex_table = env.ex_table;
       closure_table = env.closure_table;
     }
@@ -188,6 +192,9 @@ end = struct
   let find_approx t var : Export_info.approx =
     try Variable.Map.find var t.var with
     | Not_found -> Value_unknown
+
+  let is_symbol_being_defined t sym =
+    Symbol.Set.mem sym t.symbols_being_defined
 end
 
 let descr_of_constant (c : Flambda.const) : Export_info.descr =
@@ -402,15 +409,18 @@ and describe_set_of_closures env (set : Flambda.set_of_closures)
 let approx_of_constant_defining_value_block_field env
       (c : Flambda.constant_defining_value_block_field) : Export_info.approx =
   match c with
-  | Symbol s -> Value_symbol s
+  | Symbol s ->
+      if Env.is_symbol_being_defined env s
+      then Value_unknown
+      else Value_symbol s
   | Const c -> Value_id (Env.new_descr env (descr_of_constant c))
 
 let describe_constant_defining_value env export_id symbol
-      (const : Flambda.constant_defining_value) =
+      ~symbols_being_defined (const : Flambda.constant_defining_value) =
   let env =
     (* Assignments of variables to export IDs are local to each constant
        defining value. *)
-    Env.empty_of_global env
+    Env.empty_of_global ~symbols_being_defined env
   in
   match const with
   | Allocated_const alloc_const ->
@@ -468,7 +478,9 @@ let describe_program (env : Env.Global.t) (program : Flambda.program) =
     match program with
     | Let_symbol (symbol, constant_defining_value, program) ->
       let id, env = Env.Global.new_symbol env symbol in
-      describe_constant_defining_value env id symbol constant_defining_value;
+      describe_constant_defining_value env id symbol
+        ~symbols_being_defined:(Symbol.Set.singleton symbol)
+        constant_defining_value;
       loop env program
     | Let_rec_symbol (defs, program) ->
       let env, defs =
@@ -485,11 +497,16 @@ let describe_program (env : Env.Global.t) (program : Flambda.program) =
             | _ -> false)
           defs
       in
+      let symbols_being_defined =
+        Symbol.Set.of_list (List.map (fun (_, sym, _) -> sym) defs)
+      in
       List.iter (fun (id, symbol, def) ->
-          describe_constant_defining_value env id symbol def)
+          describe_constant_defining_value env id symbol
+            ~symbols_being_defined def)
         other_constants;
       List.iter (fun (id, symbol, def) ->
-          describe_constant_defining_value env id symbol def)
+          describe_constant_defining_value env id symbol
+            ~symbols_being_defined def)
         project_closures;
       loop env program
     | Initialize_symbol (symbol, tag, fields, program) ->
@@ -497,7 +514,8 @@ let describe_program (env : Env.Global.t) (program : Flambda.program) =
         let env =
           (* Assignments of variables to export IDs are local to each
              [Initialize_symbol] construction. *)
-          Env.empty_of_global env
+          Env.empty_of_global
+            ~symbols_being_defined:(Symbol.Set.singleton symbol) env
         in
         let field_approxs = List.map (approx_of_expr env) fields in
         let descr : Export_info.descr =
diff --git a/middle_end/flambda/inline_and_simplify.ml b/middle_end/flambda/inline_and_simplify.ml
index 74fd021bb9..a1dffaf309 100644
--- a/middle_end/flambda/inline_and_simplify.ml
+++ b/middle_end/flambda/inline_and_simplify.ml
@@ -1630,7 +1630,6 @@ let rec simplify_program_body env r (program : Flambda.program_body)
     let approx =
       A.augment_with_symbol (A.value_block tag (Array.of_list approxs)) symbol
     in
-    let module Backend = (val (E.backend env) : Backend_intf.S) in
     let env = E.add_symbol env symbol approx in
     let program, r = simplify_program_body env r program in
     Initialize_symbol (symbol, tag, fields, program), r
diff --git a/middle_end/flambda/lift_code.ml b/middle_end/flambda/lift_code.ml
index 02292c46e1..3474b06ba5 100644
--- a/middle_end/flambda/lift_code.ml
+++ b/middle_end/flambda/lift_code.ml
@@ -19,36 +19,50 @@ open! Int_replace_polymorphic_compare
 
 type lifter = Flambda.program -> Flambda.program
 
-let rebuild_let
-    (defs : (Variable.t * Flambda.named Flambda.With_free_variables.t) list)
-    (body : Flambda.t) =
+type def =
+  | Immutable of Variable.t * Flambda.named Flambda.With_free_variables.t
+  | Mutable of Mutable_variable.t * Variable.t * Lambda.value_kind
+
+let rebuild_let (defs : def list) (body : Flambda.t) =
   let module W = Flambda.With_free_variables in
-  List.fold_left (fun body (var, def) ->
-      W.create_let_reusing_defining_expr var def body)
+  List.fold_left (fun body def ->
+    match def with
+    | Immutable(var, def) ->
+        W.create_let_reusing_defining_expr var def body
+    | Mutable(var, initial_value, contents_kind) ->
+        Flambda.Let_mutable {var; initial_value; contents_kind; body})
     body defs
 
-let rec extract_lets
-    (acc:(Variable.t * Flambda.named Flambda.With_free_variables.t) list)
-    (let_expr:Flambda.let_expr) :
-  (Variable.t * Flambda.named Flambda.With_free_variables.t) list *
-  Flambda.t Flambda.With_free_variables.t =
+let rec extract_let_expr (acc:def list) (let_expr:Flambda.let_expr) :
+  def list * Flambda.t Flambda.With_free_variables.t =
+  let module W = Flambda.With_free_variables in
+  let acc =
+    match let_expr with
+    | { var = v1; defining_expr = Expr (Let let2); _ } ->
+        let acc, body2 = extract_let_expr acc let2 in
+        Immutable(v1, W.expr body2) :: acc
+    | { var = v1; defining_expr = Expr (Let_mutable let_mut); _ } ->
+        let acc, body2 = extract_let_mutable acc let_mut in
+        Immutable(v1, W.expr body2) :: acc
+    | { var = v; _ } ->
+        Immutable(v, W.of_defining_expr_of_let let_expr) :: acc
+  in
+  let body = W.of_body_of_let let_expr in
+  extract acc body
+
+and extract_let_mutable acc (let_mut : Flambda.let_mutable) =
   let module W = Flambda.With_free_variables in
-  match let_expr with
-  | { var = v1; defining_expr = Expr (Let let2); _ } ->
-    let acc, body2 = extract_lets acc let2 in
-    let acc = (v1, W.expr body2) :: acc in
-    let body = W.of_body_of_let let_expr in
-    extract acc body
-  | { var = v; _ } ->
-    let acc = (v, W.of_defining_expr_of_let let_expr) :: acc in
-    let body = W.of_body_of_let let_expr in
-    extract acc body
+  let { Flambda.var; initial_value; contents_kind; body } = let_mut in
+  let acc = Mutable(var, initial_value, contents_kind) :: acc in
+  extract acc (W.of_expr body)
 
 and extract acc (expr : Flambda.t Flambda.With_free_variables.t) =
   let module W = Flambda.With_free_variables in
   match W.contents expr with
   | Let let_expr ->
-    extract_lets acc let_expr
+    extract_let_expr acc let_expr
+  | Let_mutable let_mutable ->
+    extract_let_mutable acc let_mutable
   | _ ->
     acc, expr
 
@@ -56,10 +70,13 @@ let rec lift_lets_expr (expr:Flambda.t) ~toplevel : Flambda.t =
   let module W = Flambda.With_free_variables in
   match expr with
   | Let let_expr ->
-    let defs, body = extract_lets [] let_expr in
-    let rev_defs =
-      List.rev_map (lift_lets_named_with_free_variables ~toplevel) defs
-    in
+    let defs, body = extract_let_expr [] let_expr in
+    let rev_defs = List.rev_map (lift_lets_def ~toplevel) defs in
+    let body = lift_lets_expr (W.contents body) ~toplevel in
+    rebuild_let (List.rev rev_defs) body
+  | Let_mutable let_mut ->
+    let defs, body = extract_let_mutable [] let_mut in
+    let rev_defs = List.rev_map (lift_lets_def ~toplevel) defs in
     let body = lift_lets_expr (W.contents body) ~toplevel in
     rebuild_let (List.rev rev_defs) body
   | e ->
@@ -68,26 +85,28 @@ let rec lift_lets_expr (expr:Flambda.t) ~toplevel : Flambda.t =
       (lift_lets_named ~toplevel)
       e
 
-and lift_lets_named_with_free_variables
-    ((var, named):Variable.t * Flambda.named Flambda.With_free_variables.t)
-      ~toplevel : Variable.t * Flambda.named Flambda.With_free_variables.t =
+and lift_lets_def def ~toplevel =
   let module W = Flambda.With_free_variables in
-  match W.contents named with
-  | Expr e ->
-    var, W.expr (W.of_expr (lift_lets_expr e ~toplevel))
-  | Set_of_closures set when not toplevel ->
-    var,
-    W.of_named
-      (Set_of_closures
-         (Flambda_iterators.map_function_bodies
-            ~f:(lift_lets_expr ~toplevel) set))
-  | Symbol _ | Const _ | Allocated_const _ | Read_mutable _
-  | Read_symbol_field (_, _) | Project_closure _ | Move_within_set_of_closures _
-  | Project_var _ | Prim _ | Set_of_closures _ ->
-    var, named
+  match def with
+  | Mutable _ -> def
+  | Immutable(var, named) ->
+    let named =
+      match W.contents named with
+      | Expr e -> W.expr (W.of_expr (lift_lets_expr e ~toplevel))
+      | Set_of_closures set when not toplevel ->
+        W.of_named
+          (Set_of_closures
+             (Flambda_iterators.map_function_bodies
+                ~f:(lift_lets_expr ~toplevel) set))
+      | Symbol _ | Const _ | Allocated_const _ | Read_mutable _
+      | Read_symbol_field (_, _) | Project_closure _
+      | Move_within_set_of_closures _ | Project_var _
+      | Prim _ | Set_of_closures _ ->
+        named
+    in
+    Immutable(var, named)
 
 and lift_lets_named _var (named:Flambda.named) ~toplevel : Flambda.named =
-  let module W = Flambda.With_free_variables in
   match named with
   | Expr e ->
     Expr (lift_lets_expr e ~toplevel)