New files for flambda

asmcomp/build_export_info.ml

@@ -0,0 +1,549 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Env : sig
+  type t
+
+  val new_descr : t -> Export_info.descr -> Export_id.t
+  val record_descr : t -> Export_id.t -> Export_info.descr -> unit
+  val get_descr : t -> Export_info.approx -> Export_info.descr option
+
+  val add_approx : t -> Variable.t -> Export_info.approx -> t
+  val add_approx_maps : t -> Export_info.approx Variable.Map.t list -> t
+  val find_approx : t -> Variable.t -> Export_info.approx
+
+  val get_symbol_descr : t -> Symbol.t -> Export_info.descr option
+
+  val new_unit_descr : t -> Export_id.t
+
+  module Global : sig
+    (* "Global" as in "without local variable bindings". *)
+    type t
+
+    val create_empty : unit -> t
+
+    val add_symbol : t -> Symbol.t -> Export_id.t -> t
+    val new_symbol : t -> Symbol.t -> Export_id.t * t
+
+    val symbol_to_export_id_map : t -> Export_id.t Symbol.Map.t
+    val export_id_to_descr_map : t -> Export_info.descr Export_id.Map.t
+  end
+
+  (** 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
+end = struct
+  let fresh_id () = Export_id.create (Compilenv.current_unit ())
+
+  module Global = struct
+    type t =
+      { sym : Export_id.t Symbol.Map.t;
+        (* Note that [ex_table]s themselves are shared (hence [ref] and not
+           [mutable]). *)
+        ex_table : Export_info.descr Export_id.Map.t ref;
+      }
+
+    let create_empty () =
+      { sym = Symbol.Map.empty;
+        ex_table = ref Export_id.Map.empty;
+      }
+
+    let add_symbol t sym export_id =
+      if Symbol.Map.mem sym t.sym then begin
+        Misc.fatal_errorf "Build_export_info.Env.Global.add_symbol: cannot \
+            rebind symbol %a in environment"
+          Symbol.print sym
+      end;
+      { t with sym = Symbol.Map.add sym export_id t.sym }
+
+    let new_symbol t sym =
+      let export_id = fresh_id () in
+      export_id, add_symbol t sym export_id
+
+    let symbol_to_export_id_map t = t.sym
+    let export_id_to_descr_map t = !(t.ex_table)
+  end
+
+  (* CR-someday mshinwell: The half-mutable nature of [t] with sharing of
+     the [ex_table] is kind of nasty.  Consider making it immutable. *)
+  type t =
+    { var : Export_info.approx Variable.Map.t;
+      sym : Export_id.t Symbol.Map.t;
+      ex_table : Export_info.descr Export_id.Map.t ref;
+    }
+
+  let empty_of_global (env : Global.t) =
+    { var = Variable.Map.empty;
+      sym = env.sym;
+      ex_table = env.ex_table;
+    }
+
+  let extern_id_descr export_id =
+    let export = Compilenv.approx_env () in
+    try Some (Export_info.find_description export export_id)
+    with Not_found -> None
+
+  let extern_symbol_descr sym =
+    if Compilenv.is_predefined_exception sym
+    then None
+    else
+      let export = Compilenv.approx_for_global (Symbol.compilation_unit sym) in
+      try
+        let id = Symbol.Map.find sym export.symbol_id in
+        let descr = Export_info.find_description export id in
+        Some descr
+      with
+      | Not_found -> None
+
+  let get_id_descr t export_id =
+    try Some (Export_id.Map.find export_id !(t.ex_table))
+    with Not_found -> extern_id_descr export_id
+
+  let get_symbol_descr t sym =
+    try
+      let export_id = Symbol.Map.find sym t.sym in
+      Some (Export_id.Map.find export_id !(t.ex_table))
+    with
+    | Not_found -> extern_symbol_descr sym
+
+  let get_descr t (approx : Export_info.approx) =
+    match approx with
+    | Value_unknown -> None
+    | Value_id export_id -> get_id_descr t export_id
+    | Value_symbol sym -> get_symbol_descr t sym
+
+  let record_descr t id (descr : Export_info.descr) =
+    if Export_id.Map.mem id !(t.ex_table) then begin
+      Misc.fatal_errorf "Build_export_info.Env.record_descr: cannot rebind \
+          export ID %a in environment"
+        Export_id.print id
+    end;
+    t.ex_table := Export_id.Map.add id descr !(t.ex_table)
+
+  let new_descr t (descr : Export_info.descr) =
+    let id = fresh_id () in
+    record_descr t id descr;
+    id
+
+  let new_unit_descr t =
+    new_descr t (Value_constptr 0)
+
+  let add_approx t var approx =
+    if Variable.Map.mem var t.var then begin
+      Misc.fatal_errorf "Build_export_info.Env.add_approx: cannot rebind \
+          variable %a in environment"
+        Variable.print var
+    end;
+    { t with var = Variable.Map.add var approx t.var; }
+
+  let add_approx_map t vars_to_approxs =
+    Variable.Map.fold (fun var approx t -> add_approx t var approx)
+      vars_to_approxs
+      t
+
+  let add_approx_maps t vars_to_approxs_list =
+    List.fold_left add_approx_map t vars_to_approxs_list
+
+  let find_approx t var : Export_info.approx =
+    try Variable.Map.find var t.var with
+    | Not_found -> Value_unknown
+end
+
+let descr_of_constant (c : Flambda.const) : Export_info.descr =
+  match c with
+  (* [Const_pointer] is an immediate value of a type whose values may be
+     boxed (typically a variant type with both constant and non-constant
+     constructors). *)
+  | Int i -> Value_int i
+  | Char c -> Value_char c
+  | Const_pointer i -> Value_constptr i
+
+let descr_of_allocated_constant (c : Allocated_const.t) : Export_info.descr =
+  match c with
+  | Float f -> Value_float f
+  | Int32 i -> Value_boxed_int (Int32, i)
+  | Int64 i -> Value_boxed_int (Int64, i)
+  | Nativeint i -> Value_boxed_int (Nativeint, i)
+  | String s ->
+    let v_string : Export_info.value_string =
+      { size = String.length s; contents = Unknown_or_mutable; }
+    in
+    Value_string v_string
+  | Immutable_string s ->
+    let v_string : Export_info.value_string =
+      { size = String.length s; contents = Contents s; }
+    in
+    Value_string v_string
+  | Immutable_float_array fs ->
+    Value_float_array {
+      contents = Contents (Array.map (fun x -> Some x) (Array.of_list fs));
+      size = List.length fs;
+    }
+  | Float_array fs ->
+    Value_float_array {
+      contents = Unknown_or_mutable;
+      size = List.length fs;
+    }
+
+let rec approx_of_expr (env : Env.t) (flam : Flambda.t) : Export_info.approx =
+  match flam with
+  | Var var -> Env.find_approx env var
+  | Let { var; defining_expr; body; _ } ->
+    let approx = descr_of_named env defining_expr in
+    let env = Env.add_approx env var approx in
+    approx_of_expr env body
+  | Let_mutable (_mut_var, _var, body) ->
+    approx_of_expr env body
+  | Let_rec (defs, body) ->
+    let env =
+      List.fold_left (fun env (var, defining_expr) ->
+          let approx = descr_of_named env defining_expr in
+          Env.add_approx env var approx)
+        env defs
+    in
+    approx_of_expr env body
+  | Apply { func; kind; _ } ->
+    begin match kind with
+    | Indirect -> Value_unknown
+    | Direct closure_id' ->
+      match Env.get_descr env (Env.find_approx env func) with
+      | Some (Value_closure
+          { closure_id; set_of_closures = { results; _ }; }) ->
+        assert (Closure_id.equal closure_id closure_id');
+        assert (Closure_id.Map.mem closure_id results);
+        Closure_id.Map.find closure_id results
+      | _ -> Value_unknown
+    end
+  | Assign _ -> Value_id (Env.new_unit_descr env)
+  | For _ -> Value_id (Env.new_unit_descr env)
+  | While _ -> Value_id (Env.new_unit_descr env)
+  | Static_raise _ | Static_catch _ | Try_with _ | If_then_else _
+  | Switch _ | String_switch _ | Send _ | Proved_unreachable ->
+    Value_unknown
+
+and descr_of_named (env : Env.t) (named : Flambda.named)
+      : Export_info.approx =
+  match named with
+  | Expr expr -> approx_of_expr env expr
+  | Symbol sym -> Value_symbol sym
+  | Read_mutable _ -> Value_unknown
+  | Read_symbol_field (sym, i) ->
+    begin match Env.get_symbol_descr env sym with
+    | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i)
+    | _ -> Value_unknown
+    end
+  | Const const ->
+    Value_id (Env.new_descr env (descr_of_constant const))
+  | Allocated_const const ->
+    Value_id (Env.new_descr env (descr_of_allocated_constant const))
+  | Prim (Pmakeblock (tag, Immutable), args, _dbg) ->
+    let approxs = List.map (Env.find_approx env) args in
+    let descr : Export_info.descr =
+      Value_block (Tag.create_exn tag, Array.of_list approxs)
+    in
+    Value_id (Env.new_descr env descr)
+  | Prim (Pfield i, [arg], _) ->
+    begin match Env.get_descr env (Env.find_approx env arg) with
+    | Some (Value_block (_, fields)) when Array.length fields > i -> fields.(i)
+    | _ -> Value_unknown
+    end
+  | Prim (Pgetglobal id, _, _) ->
+    Value_symbol (Compilenv.symbol_for_global' id)
+  | Prim _ -> Value_unknown
+  | Set_of_closures set ->
+    let descr : Export_info.descr =
+      Value_set_of_closures (describe_set_of_closures env set)
+    in
+    Value_id (Env.new_descr env descr)
+  | Project_closure { set_of_closures; closure_id; } ->
+    begin match Env.get_descr env (Env.find_approx env set_of_closures) with
+    | Some (Value_set_of_closures set_of_closures) ->
+      if not (Closure_id.Map.mem closure_id set_of_closures.results) then begin
+        Misc.fatal_errorf "Could not build export description for \
+            [Project_closure]: closure ID %a not in set of closures"
+          Closure_id.print closure_id
+      end;
+      let descr : Export_info.descr =
+        Value_closure { closure_id = closure_id; set_of_closures; }
+      in
+      Value_id (Env.new_descr env descr)
+    | _ ->
+      (* CR pchambart: This should be [assert false], but currently there are a
+         few cases where this is less precise than inline_and_simplify.
+         mshinwell: Can you elaborate? *)
+      Value_unknown
+    end
+  | Move_within_set_of_closures { closure; start_from; move_to; } ->
+    begin match Env.get_descr env (Env.find_approx env closure) with
+    | Some (Value_closure { set_of_closures; closure_id; }) ->
+      assert (Closure_id.equal closure_id start_from);
+      let descr : Export_info.descr =
+        Value_closure { closure_id = move_to; set_of_closures; }
+      in
+      Value_id (Env.new_descr env descr)
+    | _ -> Value_unknown
+    end
+  | Project_var { closure; closure_id = closure_id'; var; } ->
+    begin match Env.get_descr env (Env.find_approx env closure) with
+    | Some (Value_closure
+        { set_of_closures = { bound_vars; _ }; closure_id; }) ->
+      assert (Closure_id.equal closure_id closure_id');
+      if not (Var_within_closure.Map.mem var bound_vars) then begin
+        Misc.fatal_errorf "Project_var from %a (closure ID %a) of \
+            variable %a that is not bound by the closure.  \
+            Variables bound by the closure are: %a"
+          Variable.print closure
+          Closure_id.print closure_id
+          Var_within_closure.print var
+          (Var_within_closure.Map.print (fun _ _ -> ())) bound_vars
+      end;
+      Var_within_closure.Map.find var bound_vars
+    | _ -> Value_unknown
+    end
+
+and describe_set_of_closures env (set : Flambda.set_of_closures)
+      : Export_info.value_set_of_closures =
+  let bound_vars_approx =
+    Variable.Map.map (Env.find_approx env) set.free_vars
+  in
+  let specialised_args_approx =
+    Variable.Map.map (Env.find_approx env) set.specialised_args
+  in
+  let closures_approx =
+    (* To build an approximation of the results, we need an
+       approximation of the functions. The first one we can build is
+       one where every function returns something unknown.
+    *)
+    (* CR-someday pchambart: we could improve a bit on that by building a
+       recursive approximation of the closures: The value_closure
+       description contains a [value_set_of_closures]. We could replace
+       this field by a [Expr_id.t] or an [approx].
+       mshinwell: Deferred for now.
+    *)
+    let initial_value_set_of_closures =
+      { Export_info.
+        set_of_closures_id = set.function_decls.set_of_closures_id;
+        bound_vars = Var_within_closure.wrap_map bound_vars_approx;
+        results =
+          Closure_id.wrap_map
+            (Variable.Map.map (fun _ -> Export_info.Value_unknown)
+              set.function_decls.funs);
+        aliased_symbol = None;
+      }
+    in
+    Variable.Map.mapi (fun fun_var _function_decl ->
+        let descr : Export_info.descr =
+          Value_closure
+            { closure_id = Closure_id.wrap fun_var;
+              set_of_closures = initial_value_set_of_closures;
+            }
+        in
+        Export_info.Value_id (Env.new_descr env descr))
+      set.function_decls.funs
+  in
+  let closure_env =
+    Env.add_approx_maps env
+      [closures_approx; bound_vars_approx; specialised_args_approx]
+  in
+  let results =
+    let result_approx _var (function_decl : Flambda.function_declaration) =
+      approx_of_expr closure_env function_decl.body
+    in
+    Variable.Map.mapi result_approx set.function_decls.funs
+  in
+  { set_of_closures_id = set.function_decls.set_of_closures_id;
+    bound_vars = Var_within_closure.wrap_map bound_vars_approx;
+    results = Closure_id.wrap_map results;
+    aliased_symbol = None;
+  }
+
+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
+  | 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) =
+  let env =
+    (* Assignments of variables to export IDs are local to each constant
+       defining value. *)
+    Env.empty_of_global env
+  in
+  match const with
+  | Allocated_const alloc_const ->
+    let descr = descr_of_allocated_constant alloc_const in
+    Env.record_descr env export_id descr
+  | Block (tag, fields) ->
+    let approxs =
+      List.map (approx_of_constant_defining_value_block_field env) fields
+    in
+    Env.record_descr env export_id (Value_block (tag, Array.of_list approxs))
+  | Set_of_closures set_of_closures ->
+    let descr : Export_info.descr =
+      Value_set_of_closures
+        { (describe_set_of_closures env set_of_closures) with
+          aliased_symbol = Some symbol;
+        }
+    in
+    Env.record_descr env export_id descr
+  | Project_closure (sym, closure_id) ->
+    begin match Env.get_symbol_descr env sym with
+    | Some (Value_set_of_closures set_of_closures) ->
+      if not (Closure_id.Map.mem closure_id set_of_closures.results) then begin
+        Misc.fatal_errorf "Could not build export description for \
+            [Project_closure] constant defining value: closure ID %a not in \
+            set of closures"
+          Closure_id.print closure_id
+      end;
+      let descr =
+        Export_info.Value_closure
+          { closure_id = closure_id; set_of_closures; }
+      in
+      Env.record_descr env export_id descr
+    | None ->
+      Misc.fatal_errorf
+        "Cannot project symbol %a to closure_id %a.  \
+          No available export description@."
+        Symbol.print sym
+        Closure_id.print closure_id
+    | Some (Value_closure _) ->
+      Misc.fatal_errorf
+        "Cannot project symbol %a to closure_id %a.  \
+          The symbol is a closure instead of a set of closures.@."
+        Symbol.print sym
+        Closure_id.print closure_id
+    | Some _ ->
+      Misc.fatal_errorf
+        "Cannot project symbol %a to closure_id %a.  \
+          The symbol is not a set of closures.@."
+        Symbol.print sym
+        Closure_id.print closure_id
+    end
+
+let describe_program (env : Env.Global.t) (program : Flambda.program) =
+  let rec loop env (program : Flambda.program_body) =
+    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;
+      loop env program
+    | Let_rec_symbol (defs, program) ->
+      let env, defs =
+        List.fold_left (fun (env, defs) (symbol, def) ->
+            let id, env = Env.Global.new_symbol env symbol in
+            env, ((id, symbol, def) :: defs))
+          (env, []) defs
+      in
+      (* [Project_closure]s are separated to be handled last.  They are the
+         only values that need a description for their argument. *)
+      let project_closures, other_constants =
+        List.partition (function
+            | _, _, Flambda.Project_closure _ -> true
+            | _ -> false)
+          defs
+      in
+      List.iter (fun (id, symbol, def) ->
+          describe_constant_defining_value env id symbol def)
+        other_constants;
+      List.iter (fun (id, symbol, def) ->
+          describe_constant_defining_value env id symbol def)
+        project_closures;
+      loop env program
+    | Initialize_symbol (symbol, tag, fields, program) ->
+      let id =
+        let env =
+          (* Assignments of variables to export IDs are local to each
+             [Initialize_symbol] construction. *)
+          Env.empty_of_global env
+        in
+        let field_approxs = List.map (approx_of_expr env) fields in
+        let descr : Export_info.descr =
+          Value_block (tag, Array.of_list field_approxs)
+        in
+        Env.new_descr env descr
+      in
+      let env = Env.Global.add_symbol env symbol id in
+      loop env program
+    | Effect (_expr, program) -> loop env program
+    | End symbol -> symbol, env
+  in
+  loop env program.program_body
+
+let build_export_info ~(backend : (module Backend_intf.S))
+      (program : Flambda.program) : Export_info.t =
+  if !Clflags.opaque then
+    Export_info.empty
+  else
+    (* CR pchambart: Should probably use that instead of the ident of
+       the module as global identifier.
+       mshinwell: Is "that" the variable "_global_symbol"? *)
+    let _global_symbol, env =
+      describe_program (Env.Global.create_empty ()) program
+    in
+    let globals =
+      let root_approx : Export_info.approx =
+        Value_symbol (Compilenv.current_unit_symbol ())
+      in
+      Ident.Map.singleton (Compilenv.current_unit_id ()) root_approx
+    in
+    let sets_of_closures =
+      Flambda_utils.all_function_decls_indexed_by_set_of_closures_id program
+    in
+    let closures =
+      Flambda_utils.all_function_decls_indexed_by_closure_id program
+    in
+    let invariant_params =
+      Set_of_closures_id.Map.map
+        (fun { Flambda. function_decls; _ } ->
+           Invariant_params.invariant_params_in_recursion
+             ~backend function_decls)
+        (Flambda_utils.all_sets_of_closures_map program)
+    in
+    let unnested_values =
+      Env.Global.export_id_to_descr_map env
+    in
+    let invariant_params =
+      let export = Compilenv.approx_env () in
+      Export_id.Map.fold (fun _eid (descr:Export_info.descr)
+                           (invariant_params) ->
+          match descr with
+          | Value_closure { set_of_closures }
+          | Value_set_of_closures set_of_closures ->
+            let { Export_info.set_of_closures_id } = set_of_closures in
+            begin match
+              Set_of_closures_id.Map.find set_of_closures_id
+                export.invariant_params
+            with
+            | exception Not_found ->
+              invariant_params
+            | (set:Variable.Set.t Variable.Map.t) ->
+              Set_of_closures_id.Map.add set_of_closures_id set invariant_params
+            end
+          | _ ->
+            invariant_params)
+        unnested_values invariant_params
+    in
+    let values =
+      Export_info.nest_eid_map unnested_values
+    in
+    Export_info.create ~values ~globals
+      ~symbol_id:(Env.Global.symbol_to_export_id_map env)
+      ~offset_fun:Closure_id.Map.empty
+      ~offset_fv:Var_within_closure.Map.empty
+      ~sets_of_closures ~closures
+      ~constant_sets_of_closures:Set_of_closures_id.Set.empty
+      ~invariant_params

asmcomp/build_export_info.mli

@@ -0,0 +1,23 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Construct export information, for emission into .cmx files, from an
+    Flambda program. *)
+
+val build_export_info :
+  backend:(module Backend_intf.S) ->
+  Flambda.program ->
+  Export_info.t

asmcomp/closure_offsets.ml

@@ -0,0 +1,136 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type result = {
+  function_offsets : int Closure_id.Map.t;
+  free_variable_offsets : int Var_within_closure.Map.t;
+}
+
+let add_closure_offsets
+      { function_offsets; free_variable_offsets }
+      ({ function_decls; free_vars } : Flambda.set_of_closures) =
+  (* Build the table mapping the functions declared by the set of closures
+     to the positions of their individual "infix" closures inside the runtime
+     closure block.  (All of the environment entries will come afterwards.) *)
+  let assign_function_offset id function_decl (map, env_pos) =
+    let pos = env_pos + 1 in
+    let env_pos =
+      let arity = Flambda_utils.function_arity function_decl in
+      env_pos
+        + 1  (* GC header; either [Closure_tag] or [Infix_tag] *)
+        + 1  (* full application code pointer *)
+        + 1  (* arity *)
+        + (if arity > 1 then 1 else 0)  (* partial application code pointer *)
+    in
+    let closure_id = Closure_id.wrap id in
+    if Closure_id.Map.mem closure_id map then begin
+      Misc.fatal_errorf "Closure_offsets.add_closure_offsets: function \
+          offset for %a would be defined multiple times"
+        Closure_id.print closure_id
+    end;
+    let map = Closure_id.Map.add closure_id pos map in
+    (map, env_pos)
+  in
+  let function_offsets, free_variable_pos =
+    Variable.Map.fold assign_function_offset
+      function_decls.funs (function_offsets, -1)
+  in
+  (* Adds the mapping of free variables to their offset.  Recall that
+     projections of [Var_within_closure]s are only currently used when
+     compiling accesses to the closure of a function from outside that
+     function (in particular, as a result of inlining).  Accesses to
+     a function's own closure are compiled directly via normal [Var]
+     accesses. *)
+  (* CR-someday mshinwell: As discussed with lwhite, maybe this isn't
+     ideal, and the self accesses should be explicitly marked too. *)
+  let assign_free_variable_offset var _ (map, pos) =
+    let var_within_closure = Var_within_closure.wrap var in
+    if Var_within_closure.Map.mem var_within_closure map then begin
+      Misc.fatal_errorf "Closure_offsets.add_closure_offsets: free variable \
+          offset for %a would be defined multiple times"
+        Var_within_closure.print var_within_closure
+    end;
+    let map = Var_within_closure.Map.add var_within_closure pos map in
+    (map, pos + 1)
+  in
+  let free_variable_offsets, _ =
+    Variable.Map.fold assign_free_variable_offset
+      free_vars (free_variable_offsets, free_variable_pos)
+  in
+  { function_offsets;
+    free_variable_offsets;
+  }
+
+let compute (program:Flambda.program) =
+  let init : result =
+    { function_offsets = Closure_id.Map.empty;
+      free_variable_offsets = Var_within_closure.Map.empty;
+    }
+  in
+  let r =
+    List.fold_left add_closure_offsets
+      init (Flambda_utils.all_sets_of_closures program)
+  in
+  r
+
+let compute_reexported_offsets program
+      ~current_unit_offset_fun ~current_unit_offset_fv
+      ~imported_units_offset_fun ~imported_units_offset_fv =
+  let offset_fun = ref current_unit_offset_fun in
+  let offset_fv = ref current_unit_offset_fv in
+  let used_closure_id closure_id =
+    match Closure_id.Map.find closure_id imported_units_offset_fun with
+    | offset ->
+      assert (not (Closure_id.Map.mem closure_id current_unit_offset_fun));
+      begin match Closure_id.Map.find closure_id !offset_fun with
+      | exception Not_found ->
+        offset_fun := Closure_id.Map.add closure_id offset !offset_fun
+      | offset' -> assert (offset = offset')
+      end
+    | exception Not_found ->
+      assert (Closure_id.Map.mem closure_id current_unit_offset_fun)
+  in
+  let used_var_within_closure var =
+    match Var_within_closure.Map.find var imported_units_offset_fv with
+    | offset ->
+      assert (not (Var_within_closure.Map.mem var current_unit_offset_fv));
+      begin match Var_within_closure.Map.find var !offset_fv with
+      | exception Not_found ->
+        offset_fv := Var_within_closure.Map.add var offset !offset_fv
+      | offset' -> assert (offset = offset')
+      end
+    | exception Not_found ->
+      assert (Var_within_closure.Map.mem var current_unit_offset_fv)
+  in
+  Flambda_iterators.iter_named_of_program program
+    ~f:(fun (named : Flambda.named) ->
+      match named with
+      | Project_closure { closure_id; _ } ->
+        used_closure_id closure_id
+      | Move_within_set_of_closures { start_from; move_to; _ } ->
+        used_closure_id start_from;
+        used_closure_id move_to
+      | Project_var { closure_id; var; _ } ->
+        used_closure_id closure_id;
+        used_var_within_closure var
+      | Symbol _ | Const _ | Allocated_const _ | Read_mutable _
+      | Read_symbol_field _ | Set_of_closures _ | Prim _ | Expr _ -> ());
+  Flambda_iterators.iter_constant_defining_values_on_program program
+    ~f:(fun (const : Flambda.constant_defining_value) ->
+      match const with
+      | Project_closure (_, closure_id) -> used_closure_id closure_id
+      | Allocated_const _ | Block _ | Set_of_closures _ -> ());
+  !offset_fun, !offset_fv

asmcomp/closure_offsets.mli

@@ -0,0 +1,42 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Assign numerical offsets, within closure blocks, for code pointers and
+    environment entries. *)
+
+type result = private {
+  function_offsets : int Closure_id.Map.t;
+  free_variable_offsets : int Var_within_closure.Map.t;
+}
+
+val compute : Flambda.program -> result
+
+(** If compilation unit [C] references [B], which contains functions inlined
+    from another compilation unit [A], then we may need to know the layout of
+    closures inside (or constructed by code inside) a.cmx in order to
+    compile c.cmx.  Unfortunately a.cmx is permitted to be absent during such
+    compilation; c.cmx will be compiled using just b.cmx.  As such, when
+    building the .cmx export information for a given compilation unit, we
+    also include information about the layout of any closures that it depends
+    on from other compilation units.  This means that when situations as just
+    describe arise, we always have access to the necessary closure offsets. *)
+val compute_reexported_offsets
+   : Flambda.program
+  -> current_unit_offset_fun:int Closure_id.Map.t
+  -> current_unit_offset_fv:int Var_within_closure.Map.t
+  -> imported_units_offset_fun:int Closure_id.Map.t
+  -> imported_units_offset_fv:int Var_within_closure.Map.t
+  -> int Closure_id.Map.t * int Var_within_closure.Map.t

asmcomp/export_info.ml

@@ -0,0 +1,356 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type value_string_contents =
+  | Contents of string
+  | Unknown_or_mutable
+
+type value_string = {
+  contents : value_string_contents;
+  size : int;
+}
+
+type value_float_array_contents =
+  | Contents of float option array
+  | Unknown_or_mutable
+
+type value_float_array = {
+  contents : value_float_array_contents;
+  size : int;
+}
+
+type descr =
+  | Value_block of Tag.t * approx array
+  | Value_mutable_block of Tag.t * int
+  | Value_int of int
+  | Value_char of char
+  | Value_constptr of int
+  | Value_float of float
+  | Value_float_array of value_float_array
+  | Value_boxed_int : 'a Simple_value_approx.boxed_int * 'a -> descr
+  | Value_string of value_string
+  | Value_closure of value_closure
+  | Value_set_of_closures of value_set_of_closures
+
+and value_closure = {
+  closure_id : Closure_id.t;
+  set_of_closures : value_set_of_closures;
+}
+
+and value_set_of_closures = {
+  set_of_closures_id : Set_of_closures_id.t;
+  bound_vars : approx Var_within_closure.Map.t;
+  results : approx Closure_id.Map.t;
+  aliased_symbol : Symbol.t option;
+}
+
+and approx =
+  | Value_unknown
+  | Value_id of Export_id.t
+  | Value_symbol of Symbol.t
+
+let equal_approx (a1:approx) (a2:approx) =
+  match a1, a2 with
+  | Value_unknown, Value_unknown ->
+    true
+  | Value_id id1, Value_id id2 ->
+    Export_id.equal id1 id2
+  | Value_symbol s1, Value_symbol s2 ->
+    Symbol.equal s1 s2
+  | (Value_unknown | Value_symbol _ | Value_id _),
+    (Value_unknown | Value_symbol _ | Value_id _) ->
+    false
+
+let equal_array eq a1 a2 =
+  Array.length a1 = Array.length a2 &&
+  try
+    Array.iteri (fun i v1 -> if not (eq a2.(i) v1) then raise Exit) a1;
+    true
+  with Exit -> false
+
+let equal_option eq o1 o2 =
+  match o1, o2 with
+  | None, None -> true
+  | Some v1, Some v2 -> eq v1 v2
+  | Some _, None | None, Some _ -> false
+
+let equal_set_of_closures (s1:value_set_of_closures) (s2:value_set_of_closures) =
+  Set_of_closures_id.equal s1.set_of_closures_id s2.set_of_closures_id &&
+  Var_within_closure.Map.equal equal_approx s1.bound_vars s2.bound_vars &&
+  Closure_id.Map.equal equal_approx s1.results s2.results &&
+  equal_option Symbol.equal s1.aliased_symbol s2.aliased_symbol
+
+let equal_descr (d1:descr) (d2:descr) : bool =
+  match d1, d2 with
+  | Value_block (t1, f1), Value_block (t2, f2) ->
+    Tag.equal t1 t2 && equal_array equal_approx f1 f2
+  | Value_mutable_block (t1, s1), Value_mutable_block (t2, s2) ->
+    Tag.equal t1 t2 &&
+    s1 = s2
+  | Value_int i1, Value_int i2 ->
+    i1 = i2
+  | Value_char c1, Value_char c2 ->
+    c1 = c2
+  | Value_constptr i1, Value_constptr i2 ->
+    i1 = i2
+  | Value_float f1, Value_float f2 ->
+    f1 = f2
+  | Value_float_array s1, Value_float_array s2 ->
+    s1 = s2
+  | Value_boxed_int (t1, v1), Value_boxed_int (t2, v2) ->
+    Simple_value_approx.equal_boxed_int t1 v1 t2 v2
+  | Value_string s1, Value_string s2 ->
+    s1 = s2
+  | Value_closure c1, Value_closure c2 ->
+    Closure_id.equal c1.closure_id c2.closure_id &&
+    equal_set_of_closures c1.set_of_closures c2.set_of_closures
+  | Value_set_of_closures s1, Value_set_of_closures s2 ->
+    equal_set_of_closures s1 s2
+  | ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _
+    | Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _
+    | Value_boxed_int _ | Value_string _ | Value_closure _
+    | Value_set_of_closures _ ),
+    ( Value_block (_, _) | Value_mutable_block (_, _) | Value_int _
+    | Value_char _ | Value_constptr _ | Value_float _ | Value_float_array _
+    | Value_boxed_int _ | Value_string _ | Value_closure _
+    | Value_set_of_closures _ ) ->
+    false
+
+type t = {
+  sets_of_closures : Flambda.function_declarations Set_of_closures_id.Map.t;
+  closures : Flambda.function_declarations Closure_id.Map.t;
+  values : descr Export_id.Map.t Compilation_unit.Map.t;
+  globals : approx Ident.Map.t;
+  symbol_id : Export_id.t Symbol.Map.t;
+  offset_fun : int Closure_id.Map.t;
+  offset_fv : int Var_within_closure.Map.t;
+  constant_sets_of_closures : Set_of_closures_id.Set.t;
+  invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t;
+}
+
+let empty : t = {
+  sets_of_closures = Set_of_closures_id.Map.empty;
+  closures = Closure_id.Map.empty;
+  values = Compilation_unit.Map.empty;
+  globals = Ident.Map.empty;
+  symbol_id = Symbol.Map.empty;
+  offset_fun = Closure_id.Map.empty;
+  offset_fv = Var_within_closure.Map.empty;
+  constant_sets_of_closures = Set_of_closures_id.Set.empty;
+  invariant_params = Set_of_closures_id.Map.empty;
+}
+
+let create ~sets_of_closures ~closures ~values ~globals ~symbol_id
+      ~offset_fun ~offset_fv ~constant_sets_of_closures
+      ~invariant_params =
+  { sets_of_closures;
+    closures;
+    values;
+    globals;
+    symbol_id;
+    offset_fun;
+    offset_fv;
+    constant_sets_of_closures;
+    invariant_params;
+  }
+
+let add_clambda_info t ~offset_fun ~offset_fv ~constant_sets_of_closures =
+  assert (Closure_id.Map.cardinal t.offset_fun = 0);
+  assert (Var_within_closure.Map.cardinal t.offset_fv = 0);
+  assert (Set_of_closures_id.Set.cardinal t.constant_sets_of_closures = 0);
+  { t with offset_fun; offset_fv; constant_sets_of_closures; }
+
+let merge (t1 : t) (t2 : t) : t =
+  let eidmap_disjoint_union ?eq map1 map2 =
+    Compilation_unit.Map.merge (fun _id map1 map2 ->
+        match map1, map2 with
+        | None, None -> None
+        | None, Some map
+        | Some map, None -> Some map
+        | Some map1, Some map2 ->
+          Some (Export_id.Map.disjoint_union ?eq map1 map2))
+      map1 map2
+  in
+  let int_eq (i : int) j = i = j in
+  { values = eidmap_disjoint_union ~eq:equal_descr t1.values t2.values;
+    globals = Ident.Map.disjoint_union t1.globals t2.globals;
+    sets_of_closures =
+      Set_of_closures_id.Map.disjoint_union t1.sets_of_closures
+        t2.sets_of_closures;
+    closures = Closure_id.Map.disjoint_union t1.closures t2.closures;
+    symbol_id = Symbol.Map.disjoint_union t1.symbol_id t2.symbol_id;
+    offset_fun = Closure_id.Map.disjoint_union
+        ~eq:int_eq t1.offset_fun t2.offset_fun;
+    offset_fv = Var_within_closure.Map.disjoint_union
+        ~eq:int_eq t1.offset_fv t2.offset_fv;
+    constant_sets_of_closures =
+      Set_of_closures_id.Set.union t1.constant_sets_of_closures
+        t2.constant_sets_of_closures;
+    invariant_params =
+      Set_of_closures_id.Map.disjoint_union
+        ~eq:(Variable.Map.equal Variable.Set.equal)
+        t1.invariant_params t2.invariant_params;
+  }
+
+let find_value eid map =
+  let unit_map = Compilation_unit.Map.find (Export_id.get_compilation_unit eid) map in
+  Export_id.Map.find eid unit_map
+
+let find_description (t : t) eid =
+  find_value eid t.values
+
+let nest_eid_map map =
+  let add_map eid v map =
+    let unit = Export_id.get_compilation_unit eid in
+    let m =
+      try Compilation_unit.Map.find unit map
+      with Not_found -> Export_id.Map.empty
+    in
+    Compilation_unit.Map.add unit (Export_id.Map.add eid v m) map
+  in
+  Export_id.Map.fold add_map map Compilation_unit.Map.empty
+
+let print_approx ppf (t : t) =
+  let values = t.values in
+  let fprintf = Format.fprintf in
+  let printed = ref Export_id.Set.empty in
+  let recorded_symbol = ref Symbol.Set.empty in
+  let symbols_to_print = Queue.create () in
+  let printed_set_of_closures = ref Set_of_closures_id.Set.empty in
+  let rec print_approx ppf (approx : approx) =
+    match approx with
+    | Value_unknown -> fprintf ppf "?"
+    | Value_id id ->
+      if Export_id.Set.mem id !printed then
+        fprintf ppf "(%a: _)" Export_id.print id
+      else begin
+        try
+          let descr = find_value id values in
+          printed := Export_id.Set.add id !printed;
+          fprintf ppf "@[<hov 2>(%a:@ %a)@]" Export_id.print id print_descr descr
+        with Not_found ->
+          fprintf ppf "(%a: Not available)" Export_id.print id
+      end
+    | Value_symbol sym ->
+      if not (Symbol.Set.mem sym !recorded_symbol) then begin
+        recorded_symbol := Symbol.Set.add sym !recorded_symbol;
+        Queue.push sym symbols_to_print;
+      end;
+      Symbol.print ppf sym
+  and print_descr ppf (descr : descr) =
+    match descr with
+    | Value_int i -> Format.pp_print_int ppf i
+    | Value_char c -> fprintf ppf "%c" c
+    | Value_constptr i -> fprintf ppf "%ip" i
+    | Value_block (tag, fields) ->
+      fprintf ppf "[%a:%a]" Tag.print tag print_fields fields
+    | Value_mutable_block (tag, size) ->
+      fprintf ppf "[mutable %a:%i]" Tag.print tag size
+    | Value_closure {closure_id; set_of_closures} ->
+      fprintf ppf "(closure %a, %a)" Closure_id.print closure_id
+        print_set_of_closures set_of_closures
+    | Value_set_of_closures set_of_closures ->
+      fprintf ppf "(set_of_closures %a)" print_set_of_closures set_of_closures
+    | Value_string { contents; size } ->
+      begin match contents with
+      | Unknown_or_mutable -> Format.fprintf ppf "string %i" size
+      | Contents s ->
+        let s =
+          if size > 10
+          then String.sub s 0 8 ^ "..."
+          else s
+        in
+        Format.fprintf ppf "string %i %S" size s
+      end
+    | Value_float f -> Format.pp_print_float ppf f
+    | Value_float_array float_array ->
+      Format.fprintf ppf "float_array%s %i"
+        (match float_array.contents with
+          | Unknown_or_mutable -> ""
+          | Contents _ -> "_imm")
+        float_array.size
+    | Value_boxed_int (t, i) ->
+      let module A = Simple_value_approx in
+      match t with
+      | A.Int32 -> Format.fprintf ppf "%li" i
+      | A.Int64 -> Format.fprintf ppf "%Li" i
+      | A.Nativeint -> Format.fprintf ppf "%ni" i
+  and print_fields ppf fields =
+    Array.iter (fun approx -> fprintf ppf "%a@ " print_approx approx) fields
+  and print_set_of_closures ppf
+      { set_of_closures_id; bound_vars; aliased_symbol } =
+    if Set_of_closures_id.Set.mem set_of_closures_id !printed_set_of_closures
+    then fprintf ppf "%a" Set_of_closures_id.print set_of_closures_id
+    else begin
+      printed_set_of_closures :=
+        Set_of_closures_id.Set.add set_of_closures_id !printed_set_of_closures;
+      let print_alias ppf = function
+        | None -> ()
+        | Some symbol ->
+          Format.fprintf ppf "@ (alias: %a)" Symbol.print symbol
+      in
+      fprintf ppf "{%a: %a%a}"
+        Set_of_closures_id.print set_of_closures_id
+        print_binding bound_vars
+        print_alias aliased_symbol
+    end
+  and print_binding ppf bound_vars =
+    Var_within_closure.Map.iter (fun clos_id approx ->
+        fprintf ppf "%a -> %a,@ "
+          Var_within_closure.print clos_id
+          print_approx approx)
+      bound_vars
+  in
+  let print_approxs id approx =
+    fprintf ppf "%a -> %a;@ " Ident.print id print_approx approx
+  in
+  let rec print_recorded_symbols () =
+    if not (Queue.is_empty symbols_to_print) then begin
+      let sym = Queue.pop symbols_to_print in
+      begin match Symbol.Map.find sym t.symbol_id with
+      | exception Not_found -> ()
+      | id ->
+        fprintf ppf "@[<hov 2>%a:@ %a@];@ "
+          Symbol.print sym
+          print_approx (Value_id id)
+      end;
+      print_recorded_symbols ();
+    end
+  in
+  fprintf ppf "@[<hov 2>Globals:@ ";
+  Ident.Map.iter print_approxs t.globals;
+  fprintf ppf "@]@ @[<hov 2>Symbols:@ ";
+  print_recorded_symbols ();
+  fprintf ppf "@]"
+
+let print_offsets ppf (t : t) =
+  Format.fprintf ppf "@[<v 2>offset_fun:@ ";
+  Closure_id.Map.iter (fun cid off ->
+      Format.fprintf ppf "%a -> %i@ "
+        Closure_id.print cid off) t.offset_fun;
+  Format.fprintf ppf "@]@ @[<v 2>offset_fv:@ ";
+  Var_within_closure.Map.iter (fun vid off ->
+      Format.fprintf ppf "%a -> %i@ "
+        Var_within_closure.print vid off) t.offset_fv;
+  Format.fprintf ppf "@]@ "
+
+let print_all ppf (t : t) =
+  let fprintf = Format.fprintf in
+  fprintf ppf "approxs@ %a@.@."
+    print_approx t;
+  fprintf ppf "functions@ %a@.@."
+    (Set_of_closures_id.Map.print Flambda.print_function_declarations)
+    t.sets_of_closures

asmcomp/export_info.mli

@@ -0,0 +1,150 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Exported information (that is to say, information written into a .cmx
+    file) about a compilation unit. *)
+
+type value_string_contents =
+  | Contents of string
+  | Unknown_or_mutable
+
+type value_string = {
+  contents : value_string_contents;
+  size : int;
+}
+
+type value_float_array_contents =
+  | Contents of float option array
+  | Unknown_or_mutable
+
+type value_float_array = {
+  contents : value_float_array_contents;
+  size : int;
+}
+
+type descr =
+  | Value_block of Tag.t * approx array
+  | Value_mutable_block of Tag.t * int
+  | Value_int of int
+  | Value_char of char
+  | Value_constptr of int
+  | Value_float of float
+  | Value_float_array of value_float_array
+  | Value_boxed_int : 'a Simple_value_approx.boxed_int * 'a -> descr
+  | Value_string of value_string
+  | Value_closure of value_closure
+  | Value_set_of_closures of value_set_of_closures
+
+and value_closure = {
+  closure_id : Closure_id.t;
+  set_of_closures : value_set_of_closures;
+}
+
+and value_set_of_closures = {
+  set_of_closures_id : Set_of_closures_id.t;
+  bound_vars : approx Var_within_closure.Map.t;
+  results : approx Closure_id.Map.t;
+  aliased_symbol : Symbol.t option;
+}
+
+(* CR-soon mshinwell: Fix the export information so we can correctly
+   propagate "unresolved due to..." in the manner of [Simple_value_approx].
+   Unfortunately this seems to be complicated by the fact that, during
+   [Import_approx], resolution can fail not only due to missing symbols but
+   also due to missing export IDs.  The argument type of
+   [Simple_value_approx.t] may need updating to reflect this (make the
+   symbol optional?  It's only for debugging anyway.) *)
+and approx =
+  | Value_unknown
+  | Value_id of Export_id.t
+  | Value_symbol of Symbol.t
+
+(** A structure that describes what a single compilation unit exports. *)
+type t = private {
+  sets_of_closures : Flambda.function_declarations Set_of_closures_id.Map.t;
+  (** Code of exported functions indexed by set of closures IDs. *)
+  closures : Flambda.function_declarations Closure_id.Map.t;
+  (** Code of exported functions indexed by closure IDs. *)
+  values : descr Export_id.Map.t Compilation_unit.Map.t;
+  (** Structure of exported values. *)
+  globals : approx Ident.Map.t;
+  (** Global variables provided by the unit: usually only the top-level
+      module identifier, but packs may contain more than one. *)
+  symbol_id : Export_id.t Symbol.Map.t;
+  (** Associates symbols and values. *)
+  offset_fun : int Closure_id.Map.t;
+  (** Positions of function pointers in their closures. *)
+  offset_fv : int Var_within_closure.Map.t;
+  (** Positions of value pointers in their closures. *)
+  constant_sets_of_closures : Set_of_closures_id.Set.t;
+  (* CR mshinwell for pchambart: Add comment *)
+  invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t;
+  (* Function parameters known to be invariant (see [Invariant_params])
+     indexed by set of closures ID. *)
+}
+
+(** Export information for a compilation unit that exports nothing. *)
+val empty : t
+
+(** Create a new export information structure. *)
+val create
+   : sets_of_closures:Flambda.function_declarations Set_of_closures_id.Map.t
+  -> closures:Flambda.function_declarations Closure_id.Map.t
+  -> values:descr Export_id.Map.t Compilation_unit.Map.t
+  -> globals:approx Ident.Map.t
+  -> symbol_id:Export_id.t Symbol.Map.t
+  -> offset_fun:int Closure_id.Map.t
+  -> offset_fv:int Var_within_closure.Map.t
+  -> constant_sets_of_closures:Set_of_closures_id.Set.t
+  -> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t
+  -> t
+
+(* CR-someday pchambart: Should we separate [t] in 2 types: one created by the
+   current [create] function, returned by [Build_export_info]. And
+   another built using t and offset_informations returned by
+   [flambda_to_clambda] ?
+   mshinwell: I think we should, but after we've done the first release.
+*)
+(** Record information about the layout of closures and which sets of
+    closures are constant.  These are all worked out during the
+    [Flambda_to_clambda] pass. *)
+val add_clambda_info
+   : t
+  -> offset_fun:int Closure_id.Map.t
+  -> offset_fv:int Var_within_closure.Map.t
+  -> constant_sets_of_closures:Set_of_closures_id.Set.t
+  -> t
+
+(** Union of export information.  Verifies that there are no identifier
+    clashes. *)
+val merge : t -> t -> t
+
+(** Look up the description of an exported value given its export ID. *)
+val find_description
+   : t
+  -> Export_id.t
+  -> descr
+
+(** Partition a mapping from export IDs by compilation unit. *)
+val nest_eid_map
+   : 'a Export_id.Map.t
+  -> 'a Export_id.Map.t Compilation_unit.Map.t
+
+(**/**)
+(* Debug printing functions. *)
+val print_approx : Format.formatter -> t -> unit
+val print_offsets : Format.formatter -> t -> unit
+val print_all : Format.formatter -> t -> unit

asmcomp/export_info_for_pack.ml

@@ -0,0 +1,143 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+let rename_id_state = Export_id.Tbl.create 100
+
+(* Rename export identifiers' compilation units to denote that they now
+   live within a pack. *)
+let import_eid_for_pack units pack id =
+  try Export_id.Tbl.find rename_id_state id
+  with Not_found ->
+    let unit_id = Export_id.get_compilation_unit id in
+    let id' =
+      if Compilation_unit.Set.mem unit_id units
+      then Export_id.create ?name:(Export_id.name id) pack
+      else id
+    in
+    Export_id.Tbl.add rename_id_state id id';
+    id'
+
+(* Similar to [import_eid_for_pack], but for symbols. *)
+let import_symbol_for_pack units pack symbol =
+  let compilation_unit = Symbol.compilation_unit symbol in
+  if Compilation_unit.Set.mem compilation_unit units
+  then Symbol.import_for_pack ~pack symbol
+  else symbol
+
+let import_approx_for_pack units pack (approx : Export_info.approx)
+      : Export_info.approx =
+  match approx with
+  | Value_symbol sym -> Value_symbol (import_symbol_for_pack units pack sym)
+  | Value_id eid -> Value_id (import_eid_for_pack units pack eid)
+  | Value_unknown -> Value_unknown
+
+let import_set_of_closures units pack
+      (set_of_closures : Export_info.value_set_of_closures)
+      : Export_info.value_set_of_closures =
+  { set_of_closures_id = set_of_closures.set_of_closures_id;
+    bound_vars =
+      Var_within_closure.Map.map (import_approx_for_pack units pack)
+        set_of_closures.bound_vars;
+    results =
+      Closure_id.Map.map (import_approx_for_pack units pack)
+        set_of_closures.results;
+    aliased_symbol =
+      Misc.may_map
+        (import_symbol_for_pack units pack)
+        set_of_closures.aliased_symbol;
+  }
+
+let import_descr_for_pack units pack (descr : Export_info.descr)
+      : Export_info.descr =
+  match descr with
+  | Value_int _
+  | Value_char _
+  | Value_constptr _
+  | Value_string _
+  | Value_float _
+  | Value_float_array _
+  | Export_info.Value_boxed_int _
+  | Value_mutable_block _ as desc -> desc
+  | Value_block (tag, fields) ->
+    Value_block (tag, Array.map (import_approx_for_pack units pack) fields)
+  | Value_closure { closure_id; set_of_closures } ->
+    Value_closure {
+      closure_id;
+      set_of_closures = import_set_of_closures units pack set_of_closures;
+    }
+  | Value_set_of_closures set_of_closures ->
+    Value_set_of_closures (import_set_of_closures units pack set_of_closures)
+
+let import_code_for_pack units pack expr =
+  Flambda_iterators.map_named (function
+      | Symbol sym -> Symbol (import_symbol_for_pack units pack sym)
+      | Read_symbol_field (sym, field) ->
+        Read_symbol_field (import_symbol_for_pack units pack sym, field)
+      | e -> e)
+    expr
+
+let import_function_declarations_for_pack units pack
+      (function_decls : Flambda.function_declarations) =
+  let funs =
+    Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
+        Flambda.create_function_declaration ~params:function_decl.params
+          ~body:(import_code_for_pack units pack function_decl.body)
+          ~stub:function_decl.stub ~dbg:function_decl.dbg
+          ~inline:function_decl.inline
+          ~is_a_functor:function_decl.is_a_functor)
+      function_decls.funs
+  in
+  Flambda.update_function_declarations function_decls ~funs
+
+let import_eidmap_for_pack units pack f map =
+  Export_info.nest_eid_map
+    (Compilation_unit.Map.fold
+      (fun _ map acc -> Export_id.Map.disjoint_union map acc)
+      (Compilation_unit.Map.map (fun map ->
+          Export_id.Map.map_keys (import_eid_for_pack units pack)
+            (Export_id.Map.map f map))
+        map)
+      Export_id.Map.empty)
+
+let import_for_pack ~pack_units ~pack (exp : Export_info.t) =
+  let import_sym = import_symbol_for_pack pack_units pack in
+  let import_descr = import_descr_for_pack pack_units pack in
+  let import_approx = import_approx_for_pack pack_units pack in
+  let import_eid = import_eid_for_pack pack_units pack in
+  let import_eidmap f map = import_eidmap_for_pack pack_units pack f map in
+  let sets_of_closures =
+    Set_of_closures_id.Map.map
+      (import_function_declarations_for_pack pack_units pack)
+      exp.sets_of_closures
+  in
+  (* The only reachable global identifier of a pack is the pack itself. *)
+  let globals =
+    Ident.Map.filter (fun unit _ ->
+        Ident.same (Compilation_unit.get_persistent_ident pack) unit)
+      exp.globals
+  in
+  Export_info.create ~sets_of_closures
+    ~closures:(Flambda_utils.make_closure_map' sets_of_closures)
+    ~globals:(Ident.Map.map import_approx globals)
+    ~offset_fun:exp.offset_fun
+    ~offset_fv:exp.offset_fv
+    ~values:(import_eidmap import_descr exp.values)
+    ~symbol_id:(Symbol.Map.map_keys import_sym
+      (Symbol.Map.map import_eid exp.symbol_id))
+    ~constant_sets_of_closures:exp.constant_sets_of_closures
+    ~invariant_params:exp.invariant_params
+
+let clear_import_state () = Export_id.Tbl.clear rename_id_state

asmcomp/export_info_for_pack.mli

@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Transformations on export information that are only used for the
+    building of packs. *)
+
+(** Transform the information from [exported] to be
+    suitable to be reexported as the information for a pack named [pack]
+    containing units [pack_units].
+    It mainly changes symbols of units [pack_units] to refer to
+    [pack] instead. *)
+val import_for_pack
+   : pack_units:Compilation_unit.Set.t
+  -> pack:Compilation_unit.t
+  -> Export_info.t
+  -> Export_info.t
+
+(** Drops the state after importing several units in the same pack. *)
+val clear_import_state : unit -> unit

asmcomp/flambda_to_clambda.ml

@@ -0,0 +1,684 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type for_one_or_more_units = {
+  fun_offset_table : int Closure_id.Map.t;
+  fv_offset_table : int Var_within_closure.Map.t;
+  closures : Flambda.function_declarations Closure_id.Map.t;
+  constant_sets_of_closures : Set_of_closures_id.Set.t;
+}
+
+type t = {
+  current_unit : for_one_or_more_units;
+  imported_units : for_one_or_more_units;
+}
+
+type ('a, 'b) declaration_position =
+  | Current_unit of 'a
+  | Imported_unit of 'b
+  | Not_declared
+
+let get_fun_offset t closure_id =
+  let fun_offset_table =
+    if Closure_id.in_compilation_unit closure_id (Compilenv.current_unit ())
+    then t.current_unit.fun_offset_table
+    else t.imported_units.fun_offset_table
+  in
+  try Closure_id.Map.find closure_id fun_offset_table
+  with Not_found ->
+    Misc.fatal_errorf "Flambda_to_clambda: missing offset for closure %a"
+      Closure_id.print closure_id
+
+let get_fv_offset t var_within_closure =
+  let fv_offset_table =
+    if Var_within_closure.in_compilation_unit var_within_closure
+        (Compilenv.current_unit ())
+    then t.current_unit.fv_offset_table
+    else t.imported_units.fv_offset_table
+  in
+  try Var_within_closure.Map.find var_within_closure fv_offset_table
+  with Not_found ->
+    Misc.fatal_errorf "Flambda_to_clambda: missing offset for variable %a"
+      Var_within_closure.print var_within_closure
+
+let function_declaration_position t closure_id =
+  try
+    Current_unit (Closure_id.Map.find closure_id t.current_unit.closures)
+  with Not_found ->
+    try
+      Imported_unit (Closure_id.Map.find closure_id t.imported_units.closures)
+    with Not_found -> Not_declared
+
+let is_function_constant t closure_id =
+  match function_declaration_position t closure_id with
+  | Current_unit { set_of_closures_id } ->
+    Set_of_closures_id.Set.mem set_of_closures_id
+      t.current_unit.constant_sets_of_closures
+  | Imported_unit { set_of_closures_id } ->
+    Set_of_closures_id.Set.mem set_of_closures_id
+      t.imported_units.constant_sets_of_closures
+  | Not_declared ->
+    Misc.fatal_errorf "Flambda_to_clambda: missing closure %a"
+      Closure_id.print closure_id
+
+(* Instrumentation of closure and field accesses to try to catch compiler
+   bugs. *)
+
+let check_closure ulam named : Clambda.ulambda =
+  if not !Clflags.clambda_checks then ulam
+  else
+    let desc =
+      Primitive.simple ~name:"caml_check_value_is_closure"
+        ~arity:2 ~alloc:false
+    in
+    let str = Format.asprintf "%a" Flambda.print_named named in
+    let str_const =
+      Compilenv.new_structured_constant (Uconst_string str) ~shared:true
+    in
+    Uprim (Pccall desc,
+           [ulam; Clambda.Uconst (Uconst_ref (str_const, None))],
+           Debuginfo.none)
+
+let check_field ulam pos named_opt : Clambda.ulambda =
+  if not !Clflags.clambda_checks then ulam
+  else
+    let desc =
+      Primitive.simple ~name:"caml_check_field_access"
+        ~arity:3 ~alloc:false
+    in
+    let str =
+      match named_opt with
+      | None -> "<none>"
+      | Some named -> Format.asprintf "%a" Flambda.print_named named
+    in
+    let str_const =
+      Compilenv.new_structured_constant (Uconst_string str) ~shared:true
+    in
+    Uprim (Pccall desc, [ulam; Clambda.Uconst (Uconst_int pos);
+        Clambda.Uconst (Uconst_ref (str_const, None))],
+      Debuginfo.none)
+
+module Env : sig
+  type t
+
+  val empty : t
+
+  val add_subst : t -> Variable.t -> Clambda.ulambda -> t
+  val find_subst_exn : t -> Variable.t -> Clambda.ulambda
+
+  val add_fresh_ident : t -> Variable.t -> Ident.t * t
+  val ident_for_var_exn : t -> Variable.t -> Ident.t
+
+  val add_fresh_mutable_ident : t -> Mutable_variable.t -> Ident.t * t
+  val ident_for_mutable_var_exn : t -> Mutable_variable.t -> Ident.t
+
+  val add_allocated_const : t -> Symbol.t -> Allocated_const.t -> t
+  val allocated_const_for_symbol : t -> Symbol.t -> Allocated_const.t option
+
+  val keep_only_symbols : t -> t
+end = struct
+  type t =
+    { subst : Clambda.ulambda Variable.Map.t;
+      var : Ident.t Variable.Map.t;
+      mutable_var : Ident.t Mutable_variable.Map.t;
+      toplevel : bool;
+      allocated_constant_for_symbol : Allocated_const.t Symbol.Map.t;
+    }
+
+  let empty =
+    { subst = Variable.Map.empty;
+      var = Variable.Map.empty;
+      mutable_var = Mutable_variable.Map.empty;
+      toplevel = false;
+      allocated_constant_for_symbol = Symbol.Map.empty;
+    }
+
+  let add_subst t id subst =
+    { t with subst = Variable.Map.add id subst t.subst }
+
+  let find_subst_exn t id = Variable.Map.find id t.subst
+
+  let ident_for_var_exn t id = Variable.Map.find id t.var
+
+  let add_fresh_ident t var =
+    let id = Ident.create (Variable.unique_name var) in
+    id, { t with var = Variable.Map.add var id t.var }
+
+  let ident_for_mutable_var_exn t mut_var =
+    Mutable_variable.Map.find mut_var t.mutable_var
+
+  let add_fresh_mutable_ident t mut_var =
+    let id = Mutable_variable.unique_ident mut_var in
+    let mutable_var = Mutable_variable.Map.add mut_var id t.mutable_var in
+    id, { t with mutable_var; }
+
+  let add_allocated_const t sym cons =
+    { t with
+      allocated_constant_for_symbol =
+        Symbol.Map.add sym cons t.allocated_constant_for_symbol;
+    }
+
+  let allocated_const_for_symbol t sym =
+    try
+      Some (Symbol.Map.find sym t.allocated_constant_for_symbol)
+    with Not_found -> None
+
+  let keep_only_symbols t =
+    { empty with
+      allocated_constant_for_symbol = t.allocated_constant_for_symbol;
+    }
+end
+
+let subst_var env var : Clambda.ulambda =
+  try Env.find_subst_exn env var
+  with Not_found ->
+    try Uvar (Env.ident_for_var_exn env var)
+    with Not_found ->
+      Misc.fatal_errorf "Flambda_to_clambda: unbound variable %a@."
+        Variable.print var
+
+let subst_vars env vars = List.map (subst_var env) vars
+
+let build_uoffset ulam offset : Clambda.ulambda =
+  if offset = 0 then ulam
+  else Uoffset (ulam, offset)
+
+let to_clambda_allocated_constant (const : Allocated_const.t)
+      : Clambda.ustructured_constant =
+  match const with
+  | Float f -> Uconst_float f
+  | Int32 i -> Uconst_int32 i
+  | Int64 i -> Uconst_int64 i
+  | Nativeint i -> Uconst_nativeint i
+  | Immutable_string s | String s -> Uconst_string s
+  | Immutable_float_array a | Float_array a -> Uconst_float_array a
+
+let to_uconst_symbol env symbol : Clambda.ustructured_constant option =
+  match Env.allocated_const_for_symbol env symbol with
+  | Some ((Float _ | Int32 _ | Int64 _ | Nativeint _) as const) ->
+    Some (to_clambda_allocated_constant const)
+  | None  (* CR-soon mshinwell: Try to make this an error. *)
+  | Some _ -> None
+
+let to_clambda_symbol' env sym : Clambda.uconstant =
+  let lbl = Linkage_name.to_string (Symbol.label sym) in
+  Uconst_ref (lbl, to_uconst_symbol env sym)
+
+let to_clambda_symbol env sym : Clambda.ulambda =
+  Uconst (to_clambda_symbol' env sym)
+
+let to_clambda_const env (const : Flambda.constant_defining_value_block_field)
+      : Clambda.uconstant =
+  match const with
+  | Symbol symbol -> to_clambda_symbol' env symbol
+  | Const (Int i) -> Uconst_int i
+  | Const (Char c) -> Uconst_int (Char.code c)
+  | Const (Const_pointer i) -> Uconst_ptr i
+
+let rec to_clambda t env (flam : Flambda.t) : Clambda.ulambda =
+  match flam with
+  | Var var -> subst_var env var
+  | Let { var; defining_expr; body; _ } ->
+    let id, env_body = Env.add_fresh_ident env var in
+    Ulet (id, to_clambda_named t env var defining_expr,
+      to_clambda t env_body body)
+  | Let_mutable (mut_var, var, body) ->
+    let id, env_body = Env.add_fresh_mutable_ident env mut_var in
+    let def = subst_var env var in
+    Ulet (id, def, to_clambda t env_body body)
+  | Let_rec (defs, body) ->
+    let env, defs =
+      List.fold_right (fun (var, def) (env, defs) ->
+          let id, env = Env.add_fresh_ident env var in
+          env, (id, var, def) :: defs)
+        defs (env, [])
+    in
+    let defs =
+      List.map (fun (id, var, def) -> id, to_clambda_named t env var def) defs
+    in
+    Uletrec (defs, to_clambda t env body)
+  | Apply { func; args; kind = Direct direct_func; dbg = dbg } ->
+    to_clambda_direct_apply t func args direct_func dbg env
+  | Apply { func; args; kind = Indirect; dbg = dbg } ->
+    (* CR mshinwell for mshinwell: improve this comment *)
+    (* The closure parameter of the function is added by cmmgen, but
+       it already appears in the list of parameters of the clambda
+       function for generic calls. Notice that for direct calls it is
+       added here. *)
+    let callee = subst_var env func in
+    Ugeneric_apply (check_closure callee (Flambda.Expr (Var func)),
+      subst_vars env args, dbg)
+  | Switch (arg, sw) ->
+    let aux () : Clambda.ulambda =
+      let const_index, const_actions =
+        to_clambda_switch t env sw.consts sw.numconsts sw.failaction
+      in
+      let block_index, block_actions =
+        to_clambda_switch t env sw.blocks sw.numblocks sw.failaction
+      in
+      Uswitch (subst_var env arg,
+        { us_index_consts = const_index;
+          us_actions_consts = const_actions;
+          us_index_blocks = block_index;
+          us_actions_blocks = block_actions;
+        })
+    in
+    (* Check that the [failaction] may be duplicated.  If this is not the
+       case, share it through a static raise / static catch. *)
+    (* CR-someday pchambart for pchambart: This is overly simplified. We should verify
+       that this does not generates too bad code. If it the case, handle some
+       let cases.
+    *)
+    begin match sw.failaction with
+    | None -> aux ()
+    | Some (Static_raise _) -> aux ()
+    | Some failaction ->
+      let exn = Static_exception.create () in
+      let sw =
+        { sw with
+          failaction = Some (Flambda.Static_raise (exn, []));
+        }
+      in
+      let expr : Flambda.t =
+        Static_catch (exn, [], Switch (arg, sw), failaction)
+      in
+      to_clambda t env expr
+    end
+  | String_switch (arg, sw, def) ->
+    let arg = subst_var env arg in
+    let sw = List.map (fun (s, e) -> s, to_clambda t env e) sw in
+    let def = Misc.may_map (to_clambda t env) def in
+    Ustringswitch (arg, sw, def)
+  | Static_raise (static_exn, args) ->
+    Ustaticfail (Static_exception.to_int static_exn,
+      List.map (subst_var env) args)
+  | Static_catch (static_exn, vars, body, handler) ->
+    let env_handler, ids =
+      List.fold_right (fun var (env, ids) ->
+          let id, env = Env.add_fresh_ident env var in
+          env, id :: ids)
+        vars (env, [])
+    in
+    Ucatch (Static_exception.to_int static_exn, ids,
+      to_clambda t env body, to_clambda t env_handler handler)
+  | Try_with (body, var, handler) ->
+    let id, env_handler = Env.add_fresh_ident env var in
+    Utrywith (to_clambda t env body, id, to_clambda t env_handler handler)
+  | If_then_else (arg, ifso, ifnot) ->
+    Uifthenelse (subst_var env arg, to_clambda t env ifso,
+      to_clambda t env ifnot)
+  | While (cond, body) ->
+    Uwhile (to_clambda t env cond, to_clambda t env body)
+  | For { bound_var; from_value; to_value; direction; body } ->
+    let id, env_body = Env.add_fresh_ident env bound_var in
+    Ufor (id, subst_var env from_value, subst_var env to_value,
+      direction, to_clambda t env_body body)
+  | Assign { being_assigned; new_value } ->
+    let id =
+      try Env.ident_for_mutable_var_exn env being_assigned
+      with Not_found ->
+        Misc.fatal_errorf "Unbound mutable variable %a in [Assign]: %a"
+          Mutable_variable.print being_assigned
+          Flambda.print flam
+    in
+    Uassign (id, subst_var env new_value)
+  | Send { kind; meth; obj; args; dbg } ->
+    Usend (kind, subst_var env meth, subst_var env obj,
+      subst_vars env args, dbg)
+  | Proved_unreachable -> Uunreachable
+
+and to_clambda_named t env var (named : Flambda.named) : Clambda.ulambda =
+  match named with
+  | Symbol sym -> to_clambda_symbol env sym
+  | Const (Const_pointer n) -> Uconst (Uconst_ptr n)
+  | Const (Int n) -> Uconst (Uconst_int n)
+  | Const (Char c) -> Uconst (Uconst_int (Char.code c))
+  | Allocated_const _ ->
+    Misc.fatal_errorf "[Allocated_const] should have been lifted to a \
+        [Let_symbol] construction before [Flambda_to_clambda]: %a = %a"
+      Variable.print var
+      Flambda.print_named named
+  | Read_mutable mut_var ->
+    begin try Uvar (Env.ident_for_mutable_var_exn env mut_var)
+    with Not_found ->
+      Misc.fatal_errorf "Unbound mutable variable %a in [Read_mutable]: %a"
+        Mutable_variable.print mut_var
+        Flambda.print_named named
+    end
+  | Read_symbol_field (symbol, field) ->
+    Uprim (Pfield field, [to_clambda_symbol env symbol], Debuginfo.none)
+  | Set_of_closures set_of_closures ->
+    to_clambda_set_of_closures t env set_of_closures
+  | Project_closure { set_of_closures; closure_id } ->
+    (* CR mshinwell for pchambart: I don't understand how this comment
+       relates to this code.  Can you explain? *)
+    (* compilation of let rec in cmmgen assumes
+       that a closure is not offseted (Cmmgen.expr_size) *)
+    check_closure (
+      build_uoffset
+        (check_closure (subst_var env set_of_closures)
+           (Flambda.Expr (Var set_of_closures)))
+        (get_fun_offset t closure_id))
+      named
+  | Move_within_set_of_closures { closure; start_from; move_to } ->
+    check_closure (build_uoffset
+      (check_closure (subst_var env closure)
+         (Flambda.Expr (Var closure)))
+      ((get_fun_offset t move_to) - (get_fun_offset t start_from)))
+      named
+  | Project_var { closure; var; closure_id } ->
+    let ulam = subst_var env closure in
+    let fun_offset = get_fun_offset t closure_id in
+    let var_offset = get_fv_offset t var in
+    let pos = var_offset - fun_offset in
+    Uprim (Pfield pos,
+      [check_field (check_closure ulam (Expr (Var closure))) pos (Some named)],
+      Debuginfo.none)
+  | Prim (Pfield index, [block], dbg) ->
+    Uprim (Pfield index, [check_field (subst_var env block) index None], dbg)
+  | Prim (Psetfield (index, maybe_ptr, init), [block; new_value], dbg) ->
+    Uprim (Psetfield (index, maybe_ptr, init), [
+        check_field (subst_var env block) index None;
+        subst_var env new_value;
+      ], dbg)
+  | Prim (Popaque, args, dbg) ->
+    Uprim (Pidentity, subst_vars env args, dbg)
+  | Prim (p, args, dbg) -> Uprim (p, subst_vars env args, dbg)
+  | Expr expr -> to_clambda t env expr
+
+and to_clambda_switch t env cases num_keys default =
+  let num_keys =
+    if Numbers.Int.Set.cardinal num_keys = 0 then 0
+    else Numbers.Int.Set.max_elt num_keys + 1
+  in
+  let index = Array.make num_keys 0 in
+  let store = Flambda_utils.Switch_storer.mk_store () in
+  begin match default with
+  | Some def when List.length cases < num_keys -> ignore (store.act_store def)
+  | _ -> ()
+  end;
+  List.iter (fun (key, lam) -> index.(key) <- store.act_store lam) cases;
+  let actions = Array.map (to_clambda t env) (store.act_get ()) in
+  match actions with
+  | [| |] -> [| |], [| |]  (* May happen when [default] is [None]. *)
+  | _ -> index, actions
+
+and to_clambda_direct_apply t func args direct_func dbg env : Clambda.ulambda =
+  let closed = is_function_constant t direct_func in
+  let label = Compilenv.function_label direct_func in
+  let uargs =
+    let uargs = subst_vars env args in
+    (* CR mshinwell: improve comment.  Should we check [func] too? *)
+    (* If the function is closed, the function expression is always a
+       variable, so it is ok to drop it. Note that it means that
+       some Let can be dead. The un-anf pass should get rid of it *)
+    if closed then uargs else uargs @ [subst_var env func]
+  in
+  Udirect_apply (label, uargs, dbg)
+
+(* Describe how to build a runtime closure block that corresponds to the
+   given Flambda set of closures.
+
+   For instance the closure for the following set of closures:
+
+     let rec fun_a x =
+       if x <= 0 then 0 else fun_b (x-1) v1
+     and fun_b x y =
+       if x <= 0 then 0 else v1 + v2 + y + fun_a (x-1)
+
+   will be represented in memory as:
+
+     [ closure header; fun_a;
+       1; infix header; fun caml_curry_2;
+       2; fun_b; v1; v2 ]
+
+   fun_a and fun_b will take an additional parameter 'env' to
+   access their closure.  It will be arranged such that in the body
+   of each function the env parameter points to its own code
+   pointer.  For example, in fun_b it will be shifted by 3 words.
+
+   Hence accessing v1 in the body of fun_a is accessing the
+   6th field of 'env' and in the body of fun_b the 1st field.
+*)
+and to_clambda_set_of_closures t env
+      (({ function_decls; free_vars } : Flambda.set_of_closures)
+        as set_of_closures) : Clambda.ulambda =
+  let all_functions = Variable.Map.bindings function_decls.funs in
+  let env_var = Ident.create "env" in
+  let to_clambda_function
+        (closure_id, (function_decl : Flambda.function_declaration))
+        : Clambda.ufunction =
+    let closure_id = Closure_id.wrap closure_id in
+    let fun_offset =
+      Closure_id.Map.find closure_id t.current_unit.fun_offset_table
+    in
+    let env =
+      (* Inside the body of the function, we cannot access variables
+         declared outside, so start with a suitably clean environment.
+         Note that we must not forget the information about which allocated
+         constants contain which unboxed values. *)
+      let env = Env.keep_only_symbols env in
+      (* Add the Clambda expressions for the free variables of the function
+         to the environment. *)
+      let add_env_free_variable id _ env =
+        let var_offset =
+          try
+            Var_within_closure.Map.find
+              (Var_within_closure.wrap id) t.current_unit.fv_offset_table
+          with Not_found ->
+            Misc.fatal_errorf "Clambda.to_clambda_set_of_closures: offset for \
+                free variable %a is unknown.  Set of closures: %a"
+              Variable.print id
+              Flambda.print_set_of_closures set_of_closures
+        in
+        let pos = var_offset - fun_offset in
+        Env.add_subst env id
+          (Uprim (Pfield pos, [Clambda.Uvar env_var], Debuginfo.none))
+      in
+      let env = Variable.Map.fold add_env_free_variable free_vars env in
+      (* Add the Clambda expressions for all functions defined in the current
+         set of closures to the environment.  The various functions may be
+         retrieved by moving within the runtime closure, starting from the
+         current function's closure. *)
+      let add_env_function pos env (id, _) =
+        let offset =
+          Closure_id.Map.find (Closure_id.wrap id)
+            t.current_unit.fun_offset_table
+        in
+        let exp : Clambda.ulambda = Uoffset (Uvar env_var, offset - pos) in
+        Env.add_subst env id exp
+      in
+      List.fold_left (add_env_function fun_offset) env all_functions
+    in
+    let env_body, params =
+      List.fold_right (fun var (env, params) ->
+          let id, env = Env.add_fresh_ident env var in
+          env, id :: params)
+        function_decl.params (env, [])
+    in
+    { label = Compilenv.function_label closure_id;
+      arity = Flambda_utils.function_arity function_decl;
+      params = params @ [env_var];
+      body = to_clambda t env_body function_decl.body;
+      dbg = function_decl.dbg;
+    }
+  in
+  let funs = List.map to_clambda_function all_functions in
+  let free_vars =
+    Variable.Map.bindings (Variable.Map.map (subst_var env) free_vars)
+  in
+  Uclosure (funs, List.map snd free_vars)
+
+and to_clambda_closed_set_of_closures t env symbol
+      ({ function_decls; } : Flambda.set_of_closures)
+      : Clambda.ustructured_constant =
+  let functions = Variable.Map.bindings function_decls.funs in
+  let to_clambda_function (id, (function_decl : Flambda.function_declaration))
+        : Clambda.ufunction =
+    (* All that we need in the environment, for translating one closure from
+       a closed set of closures, is the substitutions for variables bound to
+       the various closures in the set.  Such closures will always be
+       referenced via symbols. *)
+    let env =
+      List.fold_left (fun env (var, _) ->
+          let closure_id = Closure_id.wrap var in
+          let symbol = Compilenv.closure_symbol closure_id in
+          Env.add_subst env var (to_clambda_symbol env symbol))
+        (Env.keep_only_symbols env)
+        functions
+    in
+    let env_body, params =
+      List.fold_right (fun var (env, params) ->
+          let id, env = Env.add_fresh_ident env var in
+          env, id :: params)
+        function_decl.params (env, [])
+    in
+    { label = Compilenv.function_label (Closure_id.wrap id);
+      arity = Flambda_utils.function_arity function_decl;
+      params;
+      body = to_clambda t env_body function_decl.body;
+      dbg = function_decl.dbg;
+    }
+  in
+  let ufunct = List.map to_clambda_function functions in
+  let closure_lbl = Linkage_name.to_string (Symbol.label symbol) in
+  Uconst_closure (ufunct, closure_lbl, [])
+
+let to_clambda_initialize_symbol t env symbol fields : Clambda.ulambda =
+  let fields =
+    List.mapi (fun index expr -> index, to_clambda t env expr) fields
+  in
+  let build_setfield (index, field) : Clambda.ulambda =
+    (* Note that this will never cause a write barrier hit, owing to
+       the [Initialization]. *)
+    Uprim (Psetfield (index, Pointer, Initialization),
+      [to_clambda_symbol env symbol; field],
+      Debuginfo.none)
+  in
+  match fields with
+  | [] -> Uconst (Uconst_ptr 0)
+  | h :: t ->
+    List.fold_left (fun acc (p, field) ->
+        Clambda.Usequence (build_setfield (p, field), acc))
+      (build_setfield h) t
+
+let accumulate_structured_constants t env symbol
+      (c : Flambda.constant_defining_value) acc =
+  match c with
+  | Allocated_const c ->
+    Symbol.Map.add symbol (to_clambda_allocated_constant c) acc
+  | Block (tag, fields) ->
+    let fields = List.map (to_clambda_const env) fields in
+    Symbol.Map.add symbol (Clambda.Uconst_block (Tag.to_int tag, fields)) acc
+  | Set_of_closures set_of_closures ->
+    let to_clambda_set_of_closures =
+      to_clambda_closed_set_of_closures t env symbol set_of_closures
+    in
+    Symbol.Map.add symbol to_clambda_set_of_closures acc
+  | Project_closure _ -> acc
+
+let to_clambda_program t env constants (program : Flambda.program) =
+  let rec loop env constants (program : Flambda.program_body)
+        : Clambda.ulambda * Clambda.ustructured_constant Symbol.Map.t =
+    match program with
+    | Let_symbol (symbol, alloc, program) ->
+      (* Useful only for unboxing. Since floats and boxed integers will
+         never be part of a Let_rec_symbol, handling only the Let_symbol
+         is sufficient. *)
+      let env =
+        match alloc with
+        | Allocated_const const -> Env.add_allocated_const env symbol const
+        | _ -> env
+      in
+      let constants =
+        accumulate_structured_constants t env symbol alloc constants
+      in
+      loop env constants program
+    | Let_rec_symbol (defs, program) ->
+      let constants =
+        List.fold_left (fun constants (symbol, alloc) ->
+            accumulate_structured_constants t env symbol alloc constants)
+          constants defs
+      in
+      loop env constants program
+    | Initialize_symbol (symbol, _tag, fields, program) ->
+      (* The tag is ignored here: It is used separately to generate the
+         preallocated block. Only the initialisation code is generated
+         here. *)
+      let e1 = to_clambda_initialize_symbol t env symbol fields in
+      let e2, constants = loop env constants program in
+      Usequence (e1, e2), constants
+    | Effect (expr, program) ->
+      let e1 = to_clambda t env expr in
+      let e2, constants = loop env constants program in
+      Usequence (e1, e2), constants
+    | End _ ->
+      Uconst (Uconst_ptr 0), constants
+  in
+  loop env constants program.program_body
+
+type result = {
+  expr : Clambda.ulambda;
+  preallocated_blocks : Clambda.preallocated_block list;
+  structured_constants : Clambda.ustructured_constant Symbol.Map.t;
+  exported : Export_info.t;
+}
+
+let convert (program, exported) : result =
+  let current_unit =
+    let offsets = Closure_offsets.compute program in
+    { fun_offset_table = offsets.function_offsets;
+      fv_offset_table = offsets.free_variable_offsets;
+      closures = Flambda_utils.make_closure_map program;
+      constant_sets_of_closures =
+        Flambda_utils.all_lifted_constant_sets_of_closures program;
+    }
+  in
+  let imported_units =
+    let imported = Compilenv.approx_env () in
+    { fun_offset_table = imported.offset_fun;
+      fv_offset_table = imported.offset_fv;
+      closures = imported.closures;
+      constant_sets_of_closures = imported.constant_sets_of_closures;
+    }
+  in
+  let t = { current_unit; imported_units; } in
+  let preallocated_blocks =
+    List.map (fun (symbol, tag, fields) ->
+        { Clambda.
+          symbol = Linkage_name.to_string (Symbol.label symbol);
+          tag = Tag.to_int tag;
+          size = List.length fields;
+        })
+      (Flambda_utils.initialize_symbols program)
+  in
+  let expr, structured_constants =
+    to_clambda_program t Env.empty Symbol.Map.empty program
+  in
+  let offset_fun, offset_fv =
+    Closure_offsets.compute_reexported_offsets program
+      ~current_unit_offset_fun:current_unit.fun_offset_table
+      ~current_unit_offset_fv:current_unit.fv_offset_table
+      ~imported_units_offset_fun:imported_units.fun_offset_table
+      ~imported_units_offset_fv:imported_units.fv_offset_table
+  in
+  let exported =
+    Export_info.add_clambda_info exported
+      ~offset_fun
+      ~offset_fv
+      ~constant_sets_of_closures:current_unit.constant_sets_of_closures
+  in
+  { expr; preallocated_blocks; structured_constants; exported; }

asmcomp/flambda_to_clambda.mli

@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type result = {
+  expr : Clambda.ulambda;
+  preallocated_blocks : Clambda.preallocated_block list;
+  structured_constants : Clambda.ustructured_constant Symbol.Map.t;
+  exported : Export_info.t;
+}
+
+(** Convert an Flambda program, with associated proto-export information,
+    to Clambda.
+    This yields a Clambda expression together with augmented export
+    information and details about required statically-allocated values
+    (preallocated blocks, for [Initialize_symbol], and structured
+    constants).
+
+    It is during this process that accesses to variables within
+    closures are transformed to field accesses within closure values.
+    For direct calls, the hidden closure parameter is added.  Switch
+    tables are also built.
+*)
+val convert : Flambda.program * Export_info.t -> result

asmcomp/import_approx.ml

@@ -0,0 +1,171 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+module A = Simple_value_approx
+
+let import_set_of_closures =
+  let import_function_declarations (clos : Flambda.function_declarations)
+        : Flambda.function_declarations =
+    (* CR mshinwell for pchambart: Do we still need to do this rewriting?
+       I'm wondering if maybe we don't have to any more. *)
+    let sym_to_fun_var_map (clos : Flambda.function_declarations) =
+      Variable.Map.fold (fun fun_var _ acc ->
+           let closure_id = Closure_id.wrap fun_var in
+           let sym = Compilenv.closure_symbol closure_id in
+           Symbol.Map.add sym fun_var acc)
+        clos.funs Symbol.Map.empty
+    in
+    let sym_map = sym_to_fun_var_map clos in
+    let f_named (named : Flambda.named) =
+      match named with
+      | Symbol sym ->
+        begin try Flambda.Expr (Var (Symbol.Map.find sym sym_map)) with
+        | Not_found -> named
+        end
+      | named -> named
+    in
+    let funs =
+      Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
+          let body =
+            Flambda_iterators.map_toplevel_named f_named function_decl.body
+          in
+          Flambda.create_function_declaration ~params:function_decl.params
+            ~body ~stub:function_decl.stub ~dbg:function_decl.dbg
+            ~inline:function_decl.inline
+            ~is_a_functor:function_decl.is_a_functor)
+        clos.funs
+    in
+    Flambda.update_function_declarations clos ~funs
+  in
+  let aux set_of_closures_id =
+    let ex_info = Compilenv.approx_env () in
+    let function_declarations =
+      try
+        Set_of_closures_id.Map.find set_of_closures_id
+          ex_info.sets_of_closures
+      with Not_found ->
+        Misc.fatal_errorf "[functions] does not map set of closures ID %a. \
+            ex_info = %a"
+          Set_of_closures_id.print set_of_closures_id
+          Export_info.print_all ex_info
+    in
+    import_function_declarations function_declarations
+  in
+  Set_of_closures_id.Tbl.memoize Compilenv.imported_sets_of_closures_table aux
+
+let rec import_ex ex =
+  ignore (Compilenv.approx_for_global (Export_id.get_compilation_unit ex));
+  let ex_info = Compilenv.approx_env () in
+  let import_value_set_of_closures ~set_of_closures_id ~bound_vars
+        ~(ex_info : Export_info.t) ~what : A.value_set_of_closures =
+    let bound_vars = Var_within_closure.Map.map import_approx bound_vars in
+    match
+      Set_of_closures_id.Map.find set_of_closures_id ex_info.invariant_params
+    with
+    | exception Not_found ->
+      Misc.fatal_errorf "Set of closures ID %a not found in invariant_params \
+          (when importing [%a: %s])"
+        Set_of_closures_id.print set_of_closures_id
+        Export_id.print ex
+        what
+    | invariant_params ->
+      A.create_value_set_of_closures
+        ~function_decls:(import_set_of_closures set_of_closures_id)
+        ~bound_vars
+        ~invariant_params:(lazy invariant_params)
+        ~specialised_args:Variable.Map.empty
+        ~freshening:Freshening.Project_var.empty
+  in
+  match Export_info.find_description ex_info ex with
+  | exception Not_found -> A.value_unknown Other
+  | Value_int i -> A.value_int i
+  | Value_char c -> A.value_char c
+  | Value_constptr i -> A.value_constptr i
+  | Value_float f -> A.value_float f
+  | Value_float_array float_array ->
+    begin match float_array.contents with
+    | Unknown_or_mutable ->
+      A.value_mutable_float_array ~size:float_array.size
+    | Contents contents ->
+      A.value_immutable_float_array contents
+    end
+  | Export_info.Value_boxed_int (t, i) -> A.value_boxed_int t i
+  | Value_string { size; contents } ->
+    let contents =
+      match contents with
+      | Unknown_or_mutable -> None
+      | Contents contents -> Some contents
+    in
+    A.value_string size contents
+  | Value_mutable_block _ -> A.value_unknown Other
+  | Value_block (tag, fields) ->
+    A.value_block tag (Array.map import_approx fields)
+  | Value_closure { closure_id;
+        set_of_closures =
+          { set_of_closures_id; bound_vars; aliased_symbol } } ->
+    let value_set_of_closures =
+      import_value_set_of_closures ~set_of_closures_id ~bound_vars ~ex_info
+        ~what:(Format.asprintf "Value_closure %a" Closure_id.print closure_id)
+    in
+    A.value_closure ?set_of_closures_symbol:aliased_symbol
+      value_set_of_closures closure_id
+  | Value_set_of_closures { set_of_closures_id; bound_vars; aliased_symbol } ->
+    let value_set_of_closures =
+      import_value_set_of_closures ~set_of_closures_id ~bound_vars ~ex_info
+        ~what:"Value_set_of_closures"
+    in
+    let approx = A.value_set_of_closures value_set_of_closures in
+    match aliased_symbol with
+    | None -> approx
+    | Some symbol -> A.augment_with_symbol approx symbol
+
+and import_approx (ap : Export_info.approx) =
+  match ap with
+  | Value_unknown -> A.value_unknown Other
+  | Value_id ex -> A.value_extern ex
+  | Value_symbol sym -> A.value_symbol sym
+
+let import_symbol sym =
+  if Compilenv.is_predefined_exception sym then
+    A.value_unknown Other
+  else
+    let symbol_id_map =
+      let global = Symbol.compilation_unit sym in
+      (Compilenv.approx_for_global global).symbol_id
+    in
+    match Symbol.Map.find sym symbol_id_map with
+    | approx -> A.augment_with_symbol (import_ex approx) sym
+    | exception Not_found ->
+      A.value_unresolved sym
+
+(* Note for code reviewers: Observe that [really_import] iterates until
+   the approximation description is fully resolved (or a necessary .cmx
+   file is missing). *)
+
+let rec really_import (approx : A.descr) =
+  match approx with
+  | Value_extern ex -> really_import_ex ex
+  | Value_symbol sym -> really_import_symbol sym
+  | r -> r
+
+and really_import_ex ex =
+  really_import (import_ex ex).descr
+
+and really_import_symbol sym =
+  really_import (import_symbol sym).descr
+
+let really_import_approx (approx : Simple_value_approx.t) =
+  A.replace_description approx (really_import approx.descr)

asmcomp/import_approx.mli

@@ -0,0 +1,32 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Create simple value approximations from the export information in
+    .cmx files. *)
+
+(** Given an approximation description, load .cmx files (possibly more
+    than one) until the description is fully resolved.  If a necessary .cmx
+    file cannot be found, "unresolved" will be returned. *)
+val really_import : Simple_value_approx.descr -> Simple_value_approx.descr
+
+(** Maps the description of the given approximation through [really_import]. *)
+val really_import_approx : Simple_value_approx.t -> Simple_value_approx.t
+
+(** Read and convert the approximation of a given symbol from the
+    relevant .cmx file.  Unlike the "really_" functions, this does not
+    continue to load .cmx files until the approximation is fully
+    resolved. *)
+val import_symbol : Symbol.t -> Simple_value_approx.t

asmcomp/un_anf.ml

@@ -0,0 +1,750 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* We say that an [Ident.t] is "linear" iff:
+   (a) it is used exactly once;
+   (b) it is never assigned to (using [Uassign]).
+*)
+type ident_info =
+  { used : Ident.Set.t;
+    linear : Ident.Set.t;
+    assigned : Ident.Set.t;
+    closure_environment : Ident.Set.t;
+    let_bound_vars_that_can_be_moved : Ident.Set.t;
+  }
+
+let ignore_uconstant (_ : Clambda.uconstant) = ()
+let ignore_ulambda (_ : Clambda.ulambda) = ()
+let ignore_ulambda_list (_ : Clambda.ulambda list) = ()
+let ignore_function_label (_ : Clambda.function_label) = ()
+let ignore_debuginfo (_ : Debuginfo.t) = ()
+let ignore_int (_ : int) = ()
+let ignore_ident (_ : Ident.t) = ()
+let ignore_primitive (_ : Lambda.primitive) = ()
+let ignore_string (_ : string) = ()
+let ignore_int_array (_ : int array) = ()
+let ignore_ident_list (_ : Ident.t list) = ()
+let ignore_direction_flag (_ : Asttypes.direction_flag) = ()
+let ignore_meth_kind (_ : Lambda.meth_kind) = ()
+
+(* CR-soon mshinwell: check we aren't traversing function bodies more than
+   once (need to analyse exactly what the calls are from Cmmgen into this
+   module). *)
+
+let closure_environment_ident (ufunction:Clambda.ufunction) =
+  (* The argument after the arity is the environment *)
+  if List.length ufunction.params = ufunction.arity + 1 then
+    let env_var = List.nth ufunction.params ufunction.arity in
+    assert(Ident.name env_var = "env");
+    Some env_var
+  else
+    (* closed function, no environment *)
+    None
+
+let make_ident_info (clam : Clambda.ulambda) : ident_info =
+  let t : int Ident.Tbl.t = Ident.Tbl.create 42 in
+  let assigned_idents = ref Ident.Set.empty in
+  let environment_idents = ref Ident.Set.empty in
+  let rec loop : Clambda.ulambda -> unit = function
+    (* No underscores in the pattern match, to reduce the chance of failing
+       to traverse some subexpression. *)
+    | Uvar id ->
+      begin match Ident.Tbl.find t id with
+      | n -> Ident.Tbl.replace t id (n + 1)
+      | exception Not_found -> Ident.Tbl.add t id 1
+      end
+    | Uconst const ->
+      (* The only variables that might occur in [const] are those in constant
+         closures---and those are all bound by such closures.  It follows that
+         [const] cannot contain any variables that are bound in the current
+         scope, so we do not need to count them here.  (The function bodies
+         of the closures will be traversed when this function is called from
+         [Cmmgen.transl_function].) *)
+      ignore_uconstant const
+    | Udirect_apply (label, args, dbg) ->
+      ignore_function_label label;
+      List.iter loop args;
+      ignore_debuginfo dbg
+    | Ugeneric_apply (func, args, dbg) ->
+      loop func;
+      List.iter loop args;
+      ignore_debuginfo dbg
+    | Uclosure (functions, captured_variables) ->
+      List.iter loop captured_variables;
+      List.iter (fun ({ Clambda. label; arity; params; body; dbg } as clos) ->
+          (match closure_environment_ident clos with
+           | None -> ()
+           | Some env_var ->
+             environment_idents :=
+               Ident.Set.add env_var !environment_idents);
+          ignore_function_label label;
+          ignore_int arity;
+          ignore_ident_list params;
+          loop body;
+          ignore_debuginfo dbg)
+        functions
+    | Uoffset (expr, offset) ->
+      loop expr;
+      ignore_int offset
+    | Ulet (ident, def, body) ->
+      ignore ident;
+      loop def;
+      loop body
+    | Uletrec (defs, body) ->
+      List.iter (fun (ident, def) ->
+          ignore_ident ident;
+          loop def)
+        defs;
+      loop body
+    | Uprim (prim, args, dbg) ->
+      ignore_primitive prim;
+      List.iter loop args;
+      ignore_debuginfo dbg
+    | Uswitch (cond, { us_index_consts; us_actions_consts;
+          us_index_blocks; us_actions_blocks }) ->
+      loop cond;
+      ignore_int_array us_index_consts;
+      Array.iter loop us_actions_consts;
+      ignore_int_array us_index_blocks;
+      Array.iter loop us_actions_blocks
+    | Ustringswitch (cond, branches, default) ->
+      loop cond;
+      List.iter (fun (str, branch) ->
+          ignore_string str;
+          loop branch)
+        branches;
+      Misc.may loop default
+    | Ustaticfail (static_exn, args) ->
+      ignore_int static_exn;
+      List.iter loop args
+    | Ucatch (static_exn, idents, body, handler) ->
+      ignore_int static_exn;
+      ignore_ident_list idents;
+      loop body;
+      loop handler
+    | Utrywith (body, ident, handler) ->
+      loop body;
+      ignore_ident ident;
+      loop handler
+    | Uifthenelse (cond, ifso, ifnot) ->
+      loop cond;
+      loop ifso;
+      loop ifnot
+    | Usequence (e1, e2) ->
+      loop e1;
+      loop e2
+    | Uwhile (cond, body) ->
+      loop cond;
+      loop body
+    | Ufor (ident, low, high, direction_flag, body) ->
+      ignore_ident ident;
+      loop low;
+      loop high;
+      ignore_direction_flag direction_flag;
+      loop body
+    | Uassign (ident, expr) ->
+      assigned_idents := Ident.Set.add ident !assigned_idents;
+      loop expr
+    | Usend (meth_kind, e1, e2, args, dbg) ->
+      ignore_meth_kind meth_kind;
+      loop e1;
+      loop e2;
+      List.iter loop args;
+      ignore_debuginfo dbg
+    | Uunreachable ->
+      ()
+  in
+  loop clam;
+  let linear =
+    Ident.Tbl.fold (fun id n acc ->
+        assert (n >= 1);
+        if n = 1 && not (Ident.Set.mem id !assigned_idents)
+        then Ident.Set.add id acc
+        else acc)
+      t Ident.Set.empty
+  in
+  let assigned = !assigned_idents in
+  let used =
+    (* This doesn't work transitively and thus is somewhat restricted.  In
+       particular, it does not allow us to get rid of useless chains of [let]s.
+       However it should be sufficient to remove the majority of unnecessary
+       [let] bindings that might hinder [Cmmgen]. *)
+    Ident.Tbl.fold (fun id _n acc -> Ident.Set.add id acc)
+      t assigned
+  in
+  { used; linear; assigned; closure_environment = !environment_idents;
+    let_bound_vars_that_can_be_moved = Ident.Set.empty;
+  }
+
+(* When sequences of [let]-bindings match the evaluation order in a subsequent
+   primitive or function application whose arguments are linearly-used
+   non-assigned variables bound by such lets (possibly interspersed with other
+   variables that are known to be constant), and it is known that there were no
+   intervening side-effects during the evaluation of the [let]-bindings,
+   permit substitution of the variables for their defining expressions. *)
+let let_bound_vars_that_can_be_moved ident_info (clam : Clambda.ulambda) =
+  let obviously_constant = ref Ident.Set.empty in
+  let can_move = ref Ident.Set.empty in
+  let let_stack = ref [] in
+  let examine_argument_list args =
+    let rec loop let_bound_vars (args : Clambda.ulambda list) =
+      match let_bound_vars, args with
+      | _, [] ->
+        (* We've matched all arguments and will not substitute (in the
+           current application being considered) any of the remaining
+           [let_bound_vars].  As such they may stay on the stack. *)
+        let_bound_vars
+      | [], _ ->
+        (* There are no more [let]-bindings to consider, so the stack
+           is left empty. *)
+        []
+      | let_bound_vars, (Uvar arg)::args
+          when Ident.Set.mem arg !obviously_constant ->
+        loop let_bound_vars args
+      | let_bound_var::let_bound_vars, (Uvar arg)::args
+          when Ident.same let_bound_var arg
+            && not (Ident.Set.mem arg ident_info.assigned) ->
+        assert (Ident.Set.mem arg ident_info.used);
+        assert (Ident.Set.mem arg ident_info.linear);
+        can_move := Ident.Set.add arg !can_move;
+        loop let_bound_vars args
+      | _::_, _::_ ->
+        (* The [let] sequence has ceased to match the evaluation order
+           or we have encountered some complicated argument.  In this case
+           we empty the stack to ensure that we do not end up moving an
+           outer [let] across a side effect. *)
+        []
+    in
+    (* Start at the most recent let binding and the leftmost argument
+       (the last argument to be evaluated). *)
+    let_stack := loop !let_stack args
+  in
+  let rec loop : Clambda.ulambda -> unit = function
+    | Uvar ident ->
+      if Ident.Set.mem ident ident_info.assigned then begin
+        let_stack := []
+      end
+    | Uconst const ->
+      ignore_uconstant const
+    | Udirect_apply (label, args, dbg) ->
+      ignore_function_label label;
+      examine_argument_list args;
+      (* We don't currently traverse [args]; they should all be variables
+         anyway.  If this is added in the future, take care to traverse [args]
+         following the evaluation order. *)
+      ignore_debuginfo dbg
+    | Ugeneric_apply (func, args, dbg) ->
+      examine_argument_list (args @ [func]);
+      ignore_debuginfo dbg
+    | Uclosure (functions, captured_variables) ->
+      ignore_ulambda_list captured_variables;
+      (* Start a new let stack for speed. *)
+      List.iter (fun { Clambda. label; arity; params; body; dbg; } ->
+          ignore_function_label label;
+          ignore_int arity;
+          ignore_ident_list params;
+          let_stack := [];
+          loop body;
+          let_stack := [];
+          ignore_debuginfo dbg)
+        functions
+    | Uoffset (expr, offset) ->
+      (* [expr] should usually be a variable. *)
+      examine_argument_list [expr];
+      ignore_int offset
+    | Ulet (ident, def, body) ->
+      begin match def with
+      | Uconst _ ->
+        (* The defining expression is obviously constant, so we don't
+           have to put this [let] on the stack, and we don't have to
+           traverse the defining expression either. *)
+        obviously_constant := Ident.Set.add ident !obviously_constant;
+        loop body
+      | _ ->
+        loop def;
+        if Ident.Set.mem ident ident_info.linear then begin
+          let_stack := ident::!let_stack
+        end else begin
+          (* If we encounter a non-linear [let]-binding then we must clear
+             the let stack, since we cannot now move any previous binding
+             across the non-linear one. *)
+          let_stack := []
+        end;
+        loop body
+      end
+    | Uletrec (defs, body) ->
+      (* Evaluation order for [defs] is not defined, and this case
+         probably isn't important for [Cmmgen] anyway. *)
+      let_stack := [];
+      List.iter (fun (ident, def) ->
+          ignore_ident ident;
+          loop def;
+          let_stack := [])
+        defs;
+      loop body
+    | Uprim (prim, args, dbg) ->
+      ignore_primitive prim;
+      examine_argument_list args;
+      ignore_debuginfo dbg
+    | Uswitch (cond, { us_index_consts; us_actions_consts;
+          us_index_blocks; us_actions_blocks }) ->
+      examine_argument_list [cond];
+      ignore_int_array us_index_consts;
+      Array.iter (fun action ->
+          let_stack := [];
+          loop action)
+        us_actions_consts;
+      ignore_int_array us_index_blocks;
+      Array.iter (fun action ->
+          let_stack := [];
+          loop action)
+        us_actions_blocks;
+      let_stack := []
+    | Ustringswitch (cond, branches, default) ->
+      examine_argument_list [cond];
+      List.iter (fun (str, branch) ->
+          ignore_string str;
+          let_stack := [];
+          loop branch)
+        branches;
+      let_stack := [];
+      Misc.may loop default;
+      let_stack := []
+    | Ustaticfail (static_exn, args) ->
+      ignore_int static_exn;
+      ignore_ulambda_list args;
+      let_stack := []
+    | Ucatch (static_exn, idents, body, handler) ->
+      ignore_int static_exn;
+      ignore_ident_list idents;
+      let_stack := [];
+      loop body;
+      let_stack := [];
+      loop handler;
+      let_stack := []
+    | Utrywith (body, ident, handler) ->
+      let_stack := [];
+      loop body;
+      let_stack := [];
+      ignore_ident ident;
+      loop handler;
+      let_stack := []
+    | Uifthenelse (cond, ifso, ifnot) ->
+      examine_argument_list [cond];
+      let_stack := [];
+      loop ifso;
+      let_stack := [];
+      loop ifnot;
+      let_stack := []
+    | Usequence (e1, e2) ->
+      loop e1;
+      let_stack := [];
+      loop e2;
+      let_stack := []
+    | Uwhile (cond, body) ->
+      let_stack := [];
+      loop cond;
+      let_stack := [];
+      loop body;
+      let_stack := []
+    | Ufor (ident, low, high, direction_flag, body) ->
+      ignore_ident ident;
+      (* Cmmgen generates code that evaluates low before high,
+         but we don't do anything here at the moment anyway. *)
+      ignore_ulambda low;
+      ignore_ulambda high;
+      ignore_direction_flag direction_flag;
+      let_stack := [];
+      loop body;
+      let_stack := []
+    | Uassign (ident, expr) ->
+      ignore_ident ident;
+      ignore_ulambda expr;
+      let_stack := []
+    | Usend (meth_kind, e1, e2, args, dbg) ->
+      ignore_meth_kind meth_kind;
+      ignore_ulambda e1;
+      ignore_ulambda e2;
+      ignore_ulambda_list args;
+      let_stack := [];
+      ignore_debuginfo dbg
+    | Uunreachable ->
+      let_stack := []
+  in
+  loop clam;
+  !can_move
+
+(* Substitution of an expression for a let-moveable variable can cause the
+   surrounding expression to become fixed.  To avoid confusion, do the
+   let-moveable substitutions first. *)
+let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda)
+      : Clambda.ulambda =
+  match clam with
+  | Uvar id ->
+    if not (Ident.Set.mem id is_let_moveable) then
+      clam
+    else
+      begin match Ident.Map.find id env with
+      | clam -> clam
+      | exception Not_found ->
+        Misc.fatal_errorf "substitute_let_moveable: Unbound identifier %a"
+          Ident.print id
+      end
+  | Uconst _ -> clam
+  | Udirect_apply (label, args, dbg) ->
+    let args = substitute_let_moveable_list is_let_moveable env args in
+    Udirect_apply (label, args, dbg)
+  | Ugeneric_apply (func, args, dbg) ->
+    let func = substitute_let_moveable is_let_moveable env func in
+    let args = substitute_let_moveable_list is_let_moveable env args in
+    Ugeneric_apply (func, args, dbg)
+  | Uclosure (functions, variables_bound_by_the_closure) ->
+    let functions =
+      List.map (fun (ufunction : Clambda.ufunction) ->
+          { ufunction with
+            body = substitute_let_moveable is_let_moveable env ufunction.body;
+          })
+        functions
+    in
+    let variables_bound_by_the_closure =
+      substitute_let_moveable_list is_let_moveable env variables_bound_by_the_closure
+    in
+    Uclosure (functions, variables_bound_by_the_closure)
+  | Uoffset (clam, n) ->
+    let clam = substitute_let_moveable is_let_moveable env clam in
+    Uoffset (clam, n)
+  | Ulet (id, def, body) ->
+    let def = substitute_let_moveable is_let_moveable env def in
+    if Ident.Set.mem id is_let_moveable then
+      let env = Ident.Map.add id def env in
+      substitute_let_moveable is_let_moveable env body
+    else
+      Ulet (id, def, substitute_let_moveable is_let_moveable env body)
+  | Uletrec (defs, body) ->
+    let defs =
+      List.map (fun (id, def) ->
+          id, substitute_let_moveable is_let_moveable env def)
+        defs
+    in
+    let body = substitute_let_moveable is_let_moveable env body in
+    Uletrec (defs, body)
+  | Uprim (prim, args, dbg) ->
+    let args = substitute_let_moveable_list is_let_moveable env args in
+    Uprim (prim, args, dbg)
+  | Uswitch (cond, sw) ->
+    let cond = substitute_let_moveable is_let_moveable env cond in
+    let sw =
+      { sw with
+        us_actions_consts = substitute_let_moveable_array is_let_moveable env sw.us_actions_consts;
+        us_actions_blocks = substitute_let_moveable_array is_let_moveable env sw.us_actions_blocks;
+      }
+    in
+    Uswitch (cond, sw)
+  | Ustringswitch (cond, branches, default) ->
+    let cond = substitute_let_moveable is_let_moveable env cond in
+    let branches =
+      List.map (fun (s, branch) -> s, substitute_let_moveable is_let_moveable env branch)
+        branches
+    in
+    let default = Misc.may_map (substitute_let_moveable is_let_moveable env) default in
+    Ustringswitch (cond, branches, default)
+  | Ustaticfail (n, args) ->
+    let args = substitute_let_moveable_list is_let_moveable env args in
+    Ustaticfail (n, args)
+  | Ucatch (n, ids, body, handler) ->
+    let body = substitute_let_moveable is_let_moveable env body in
+    let handler = substitute_let_moveable is_let_moveable env handler in
+    Ucatch (n, ids, body, handler)
+  | Utrywith (body, id, handler) ->
+    let body = substitute_let_moveable is_let_moveable env body in
+    let handler = substitute_let_moveable is_let_moveable env handler in
+    Utrywith (body, id, handler)
+  | Uifthenelse (cond, ifso, ifnot) ->
+    let cond = substitute_let_moveable is_let_moveable env cond in
+    let ifso = substitute_let_moveable is_let_moveable env ifso in
+    let ifnot = substitute_let_moveable is_let_moveable env ifnot in
+    Uifthenelse (cond, ifso, ifnot)
+  | Usequence (e1, e2) ->
+    let e1 = substitute_let_moveable is_let_moveable env e1 in
+    let e2 = substitute_let_moveable is_let_moveable env e2 in
+    Usequence (e1, e2)
+  | Uwhile (cond, body) ->
+    let cond = substitute_let_moveable is_let_moveable env cond in
+    let body = substitute_let_moveable is_let_moveable env body in
+    Uwhile (cond, body)
+  | Ufor (id, low, high, direction, body) ->
+    let low = substitute_let_moveable is_let_moveable env low in
+    let high = substitute_let_moveable is_let_moveable env high in
+    let body = substitute_let_moveable is_let_moveable env body in
+    Ufor (id, low, high, direction, body)
+  | Uassign (id, expr) ->
+    let expr = substitute_let_moveable is_let_moveable env expr in
+    Uassign (id, expr)
+  | Usend (kind, e1, e2, args, dbg) ->
+    let e1 = substitute_let_moveable is_let_moveable env e1 in
+    let e2 = substitute_let_moveable is_let_moveable env e2 in
+    let args = substitute_let_moveable_list is_let_moveable env args in
+    Usend (kind, e1, e2, args, dbg)
+  | Uunreachable ->
+    Uunreachable
+
+and substitute_let_moveable_list is_let_moveable env clams =
+  List.map (substitute_let_moveable is_let_moveable env) clams
+
+and substitute_let_moveable_array is_let_moveable env clams =
+  Array.map (substitute_let_moveable is_let_moveable env) clams
+
+(* We say that an expression is "moveable" iff it has neither effects nor
+   coeffects.  (See semantics_of_primitives.mli.)
+*)
+type moveable = Fixed | Moveable | Moveable_not_into_loops
+
+let both_moveable a b =
+  match a, b with
+  | Moveable, Moveable -> Moveable
+  | Moveable_not_into_loops, Moveable
+  | Moveable, Moveable_not_into_loops
+  | Moveable_not_into_loops, Moveable_not_into_loops -> Moveable_not_into_loops
+  | Moveable, Fixed
+  | Moveable_not_into_loops, Fixed
+  | Fixed, Moveable_not_into_loops
+  | Fixed, Moveable
+  | Fixed, Fixed -> Fixed
+
+let primitive_moveable (prim : Lambda.primitive)
+    (args : Clambda.ulambda list)
+    (ident_info : ident_info) =
+  match prim, args with
+  | Pfield _, [Uconst (Uconst_ref (_, _))] ->
+    (* CR mshinwell: Actually, maybe this shouldn't be needed; these should
+       have been simplified to [Read_symbol_field], which doesn't yield a
+       Clambda let.  This might be fixed when Inline_and_simplify can
+       turn Pfield into Read_symbol_field. *)
+    (* Allow field access of symbols to be moveable.  (The comment in
+       flambda.mli on [Read_symbol_field] may be helpful to the reader.) *)
+    Moveable
+  | Pfield _, [Uvar id] when Ident.Set.mem id ident_info.closure_environment ->
+    (* accesses to the function environment is coeffect free: this block
+       is never mutated *)
+    Moveable
+  | _ ->
+    match Semantics_of_primitives.for_primitive prim with
+    | No_effects, No_coeffects -> Moveable
+    | No_effects, Has_coeffects
+    | Only_generative_effects, No_coeffects
+    | Only_generative_effects, Has_coeffects
+    | Arbitrary_effects, No_coeffects
+    | Arbitrary_effects, Has_coeffects -> Fixed
+
+type moveable_for_env = Moveable | Moveable_not_into_loops
+
+(** Called when we are entering a loop or body of a function (which may be
+    called multiple times).  The environment is rewritten such that
+    identifiers previously moveable, but not into loops, are now fixed. *)
+let going_into_loop env =
+  Ident.Map.filter_map env ~f:(fun _var ((moveable : moveable_for_env), def) ->
+    match moveable with
+    | Moveable -> Some (Moveable, def)
+    | Moveable_not_into_loops -> None)
+
+(** Eliminate, through substitution, [let]-bindings of linear variables with
+    moveable defining expressions. *)
+let rec un_anf_and_moveable ident_info env (clam : Clambda.ulambda)
+      : Clambda.ulambda * moveable =
+  match clam with
+  | Uvar id ->
+    begin match Ident.Map.find id env with
+    | Moveable, def -> def, Moveable
+    | Moveable_not_into_loops, def -> def, Moveable_not_into_loops
+    | exception Not_found ->
+      let moveable : moveable =
+        if Ident.Set.mem id ident_info.assigned then
+          Fixed
+        else
+          Moveable
+      in
+      clam, moveable
+    end
+  | Uconst _ ->
+    (* Constant closures are rewritten separately. *)
+    clam, Moveable
+  | Udirect_apply (label, args, dbg) ->
+    let args = un_anf_list ident_info env args in
+    Udirect_apply (label, args, dbg), Fixed
+  | Ugeneric_apply (func, args, dbg) ->
+    let func = un_anf ident_info env func in
+    let args = un_anf_list ident_info env args in
+    Ugeneric_apply (func, args, dbg), Fixed
+  | Uclosure (functions, variables_bound_by_the_closure) ->
+    let functions =
+      List.map (fun (ufunction : Clambda.ufunction) ->
+          { ufunction with
+            body = un_anf ident_info (going_into_loop env) ufunction.body;
+          })
+        functions
+    in
+    let variables_bound_by_the_closure, moveable =
+      un_anf_list_and_moveable ident_info env variables_bound_by_the_closure
+    in
+    Uclosure (functions, variables_bound_by_the_closure),
+      both_moveable moveable Moveable_not_into_loops
+  | Uoffset (clam, n) ->
+    let clam, moveable = un_anf_and_moveable ident_info env clam in
+    Uoffset (clam, n), moveable
+  | Ulet (id, def, Uvar id') when Ident.same id id' ->
+    un_anf_and_moveable ident_info env def
+  | Ulet (id, def, body) ->
+    let def, def_moveable = un_anf_and_moveable ident_info env def in
+    let is_linear = Ident.Set.mem id ident_info.linear in
+    let is_used = Ident.Set.mem id ident_info.used in
+    begin match def_moveable, is_linear, is_used with
+    | (Moveable | Moveable_not_into_loops), _, false ->
+      (* A moveable expression that is never used may be eliminated. *)
+      un_anf_and_moveable ident_info env body
+    | Moveable, true, true ->
+      (* A moveable expression bound to a linear [Ident.t] may replace the
+         single occurrence of the identifier. *)
+      let env =
+        let def_moveable : moveable_for_env =
+          match def_moveable with
+          | Moveable -> Moveable
+          | Moveable_not_into_loops -> Moveable_not_into_loops
+          | Fixed -> assert false
+        in
+        Ident.Map.add id (def_moveable, def) env
+      in
+      un_anf_and_moveable ident_info env body
+    | Moveable_not_into_loops, true, true
+        (* We can't delete the [let] binding in this case because we don't
+           know whether the variable was substituted for its definition
+           (in the case of its linear use not being inside a loop) or not.
+           We could extend the code to cope with this case. *)
+    | (Moveable | Moveable_not_into_loops), false, true
+        (* Moveable but not used linearly. *)
+    | Fixed, _, _ ->
+      let body, body_moveable = un_anf_and_moveable ident_info env body in
+      Ulet (id, def, body), both_moveable def_moveable body_moveable
+    end
+  | Uletrec (defs, body) ->
+    let defs =
+      List.map (fun (id, def) -> id, un_anf ident_info env def) defs
+    in
+    let body = un_anf ident_info env body in
+    Uletrec (defs, body), Fixed
+  | Uprim (prim, args, dbg) ->
+    let args, args_moveable = un_anf_list_and_moveable ident_info env args in
+    let moveable =
+      both_moveable args_moveable (primitive_moveable prim args ident_info)
+    in
+    Uprim (prim, args, dbg), moveable
+  | Uswitch (cond, sw) ->
+    let cond = un_anf ident_info env cond in
+    let sw =
+      { sw with
+        us_actions_consts = un_anf_array ident_info env sw.us_actions_consts;
+        us_actions_blocks = un_anf_array ident_info env sw.us_actions_blocks;
+      }
+    in
+    Uswitch (cond, sw), Fixed
+  | Ustringswitch (cond, branches, default) ->
+    let cond = un_anf ident_info env cond in
+    let branches =
+      List.map (fun (s, branch) -> s, un_anf ident_info env branch)
+        branches
+    in
+    let default = Misc.may_map (un_anf ident_info env) default in
+    Ustringswitch (cond, branches, default), Fixed
+  | Ustaticfail (n, args) ->
+    let args = un_anf_list ident_info env args in
+    Ustaticfail (n, args), Fixed
+  | Ucatch (n, ids, body, handler) ->
+    let body = un_anf ident_info env body in
+    let handler = un_anf ident_info env handler in
+    Ucatch (n, ids, body, handler), Fixed
+  | Utrywith (body, id, handler) ->
+    let body = un_anf ident_info env body in
+    let handler = un_anf ident_info env handler in
+    Utrywith (body, id, handler), Fixed
+  | Uifthenelse (cond, ifso, ifnot) ->
+    let cond, cond_moveable = un_anf_and_moveable ident_info env cond in
+    let ifso, ifso_moveable = un_anf_and_moveable ident_info env ifso in
+    let ifnot, ifnot_moveable = un_anf_and_moveable ident_info env ifnot in
+    let moveable =
+      both_moveable cond_moveable
+        (both_moveable ifso_moveable ifnot_moveable)
+    in
+    Uifthenelse (cond, ifso, ifnot), moveable
+  | Usequence (e1, e2) ->
+    let e1 = un_anf ident_info env e1 in
+    let e2 = un_anf ident_info env e2 in
+    Usequence (e1, e2), Fixed
+  | Uwhile (cond, body) ->
+    let env = going_into_loop env in
+    let cond = un_anf ident_info env cond in
+    let body = un_anf ident_info env body in
+    Uwhile (cond, body), Fixed
+  | Ufor (id, low, high, direction, body) ->
+    let low = un_anf ident_info env low in
+    let high = un_anf ident_info env high in
+    let body = un_anf ident_info (going_into_loop env) body in
+    Ufor (id, low, high, direction, body), Fixed
+  | Uassign (id, expr) ->
+    let expr = un_anf ident_info env expr in
+    Uassign (id, expr), Fixed
+  | Usend (kind, e1, e2, args, dbg) ->
+    let e1 = un_anf ident_info env e1 in
+    let e2 = un_anf ident_info env e2 in
+    let args = un_anf_list ident_info env args in
+    Usend (kind, e1, e2, args, dbg), Fixed
+  | Uunreachable ->
+    Uunreachable, Fixed
+
+and un_anf ident_info env clam : Clambda.ulambda =
+  let clam, _moveable = un_anf_and_moveable ident_info env clam in
+  clam
+
+and un_anf_list_and_moveable ident_info env clams
+      : Clambda.ulambda list * moveable =
+  List.fold_right (fun clam (l, acc_moveable) ->
+      let clam, moveable = un_anf_and_moveable ident_info env clam in
+      clam :: l, both_moveable moveable acc_moveable)
+    clams ([], (Moveable : moveable))
+
+and un_anf_list ident_info env clams : Clambda.ulambda list =
+  let clams, _moveable = un_anf_list_and_moveable ident_info env clams in
+  clams
+
+and un_anf_array ident_info env clams : Clambda.ulambda array =
+  Array.map (un_anf ident_info env) clams
+
+let apply clam ~what =
+  if not Config.flambda then clam
+  else begin
+    let ident_info = make_ident_info clam in
+    let let_bound_vars_that_can_be_moved =
+      let_bound_vars_that_can_be_moved ident_info clam
+    in
+    let clam =
+      substitute_let_moveable let_bound_vars_that_can_be_moved
+        Ident.Map.empty clam
+    in
+    let ident_info = make_ident_info clam in
+    let clam = un_anf ident_info Ident.Map.empty clam in
+    if !Clflags.dump_clambda then begin
+      Format.eprintf "@.un-anf (%s):@ %a@." what Printclambda.clambda clam
+    end;
+    clam
+  end

asmcomp/un_anf.mli

@@ -0,0 +1,22 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Expand ANF-like constructs so that pattern matches in [Cmmgen] will
+    work correctly. *)
+val apply
+   : Clambda.ulambda
+  -> what:string
+  -> Clambda.ulambda

asmrun/clambda_checks.c

@@ -0,0 +1,84 @@
+/***********************************************************************/
+/*                                                                     */
+/*                                OCaml                                */
+/*                                                                     */
+/*                      Pierre Chambart, OCamlPro                      */
+/*                  Mark Shinwell, Jane Street Europe                  */
+/*                                                                     */
+/*  Copyright 2015 Institut National de Recherche en Informatique et   */
+/*  en Automatique.  All rights reserved.  This file is distributed    */
+/*  under the terms of the GNU Library General Public License, with    */
+/*  the special exception on linking described in file ../LICENSE.     */
+/*                                                                     */
+/***********************************************************************/
+
+/* Runtime checks to try to catch errors in code generation.
+   See flambda_to_clambda.ml for more information. */
+
+#include <assert.h>
+#include <stdio.h>
+
+#include <caml/mlvalues.h>
+
+value caml_check_value_is_closure(value v, value v_descr)
+{
+  const char* descr = String_val(v_descr);
+  value orig_v = v;
+
+  if (v == (value) 0) {
+    fprintf(stderr, "NULL is not a closure: %s\n",
+      descr);
+    abort();
+  }
+  if (!Is_block(v)) {
+    fprintf(stderr,
+      "Expecting a closure, got a non-boxed value %p: %s\n",
+      (void*) v, descr);
+    abort();
+  }
+  if (!(Tag_val(v) == Closure_tag || Tag_val(v) == Infix_tag)) {
+    fprintf(stderr,
+      "Expecting a closure, got a boxed value with tag %i: %s\n",
+      Tag_val(v), descr);
+    abort();
+  }
+  if (Tag_val(v) == Infix_tag) {
+    v -= Infix_offset_val(v);
+    assert(Tag_val(v) == Closure_tag);
+  }
+  assert(Wosize_val(v) >= 2);
+
+  return orig_v;
+}
+
+value caml_check_field_access(value v, value pos, value v_descr)
+{
+  const char* descr = String_val(v_descr);
+  value orig_v = v;
+  if (v == (value) 0) {
+    fprintf(stderr, "Access to field %lld of NULL: %s\n",
+      (unsigned long long) Long_val(pos), descr);
+    abort();
+  }
+  if (!Is_block(v)) {
+    fprintf(stderr,
+      "Access to field %lld of non-boxed value %p is illegal: %s\n",
+      (unsigned long long) Long_val(pos), (void*) v, descr);
+    abort();
+  }
+  if (Tag_val(v) == Infix_tag) {
+    uintnat offset = Infix_offset_val(v);
+    v -= offset;
+    pos += offset / sizeof(value);
+  }
+  assert(Long_val(pos) >= 0);
+  if (Long_val(pos) >= Wosize_val(v)) {
+    fprintf(stderr,
+      "Access to field %lld of value %p of size %lld is illegal: %s\n",
+      (unsigned long long) Long_val(pos), (void*) v,
+      (unsigned long long) Wosize_val(v),
+      descr);
+    abort();
+  }
+  return orig_v;
+}

middle_end/alias_analysis.ml

@@ -0,0 +1,165 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type allocation_point =
+  | Symbol of Symbol.t
+  | Variable of Variable.t
+
+type allocated_const =
+  | Normal of Allocated_const.t
+  | Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list
+  | Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t
+
+type constant_defining_value =
+  | Allocated_const of allocated_const
+  | Block of Tag.t * Variable.t list
+  | Set_of_closures of Flambda.set_of_closures
+  | Project_closure of Flambda.project_closure
+  | Move_within_set_of_closures of Flambda.move_within_set_of_closures
+  | Project_var of Flambda.project_var
+  | Field of Variable.t * int
+  | Symbol_field of Symbol.t * int
+  | Const of Flambda.const
+  | Symbol of Symbol.t
+  | Variable of Variable.t
+
+type initialize_symbol_field = Variable.t option
+
+type definitions =
+  {
+    variable : constant_defining_value Variable.Tbl.t;
+    initialize_symbol : initialize_symbol_field list Symbol.Tbl.t;
+    symbol : Flambda.constant_defining_value Symbol.Tbl.t;
+  }
+
+let print_constant_defining_value ppf = function
+  | Allocated_const (Normal const) -> Allocated_const.print ppf const
+  | Allocated_const (Array (_, _, vars)) ->
+    Format.fprintf ppf "[| %a |]"
+      (Format.pp_print_list Variable.print) vars
+  | Allocated_const (Duplicate_array (_, _, var)) ->
+    Format.fprintf ppf "dup_array(%a)" Variable.print var
+  | Block (tag, vars) ->
+    Format.fprintf ppf "[|%a: %a|]"
+      Tag.print tag
+      (Format.pp_print_list Variable.print) vars
+  | Set_of_closures set -> Flambda.print_set_of_closures ppf set
+  | Project_closure project -> Flambda.print_project_closure ppf project
+  | Move_within_set_of_closures move ->
+    Flambda.print_move_within_set_of_closures ppf move
+  | Project_var project -> Flambda.print_project_var ppf project
+  | Field (var, field) -> Format.fprintf ppf "%a.(%d)" Variable.print var field
+  | Symbol_field (sym, field) ->
+    Format.fprintf ppf "%a.(%d)" Symbol.print sym field
+  | Const const -> Flambda.print_const ppf const
+  | Symbol symbol -> Symbol.print ppf symbol
+  | Variable var -> Variable.print ppf var
+
+let rec resolve_definition
+    (definitions: definitions)
+    (var: Variable.t)
+    (def: constant_defining_value) : allocation_point =
+  match def with
+  | Allocated_const _
+  | Block _
+  | Set_of_closures _
+  | Project_closure _
+  | Const _
+  | Move_within_set_of_closures _ ->
+    Variable var
+  | Project_var {var} ->
+    fetch_variable definitions (Var_within_closure.unwrap var)
+  | Variable v ->
+    fetch_variable definitions v
+  | Symbol sym -> Symbol sym
+  | Field (v, n) ->
+    begin match fetch_variable definitions v with
+    | Symbol s ->
+      fetch_symbol_field definitions s n
+    | Variable v ->
+      fetch_variable_field definitions v n
+    end
+  | Symbol_field (symbol, field) ->
+    fetch_symbol_field definitions symbol field
+
+and fetch_variable
+    (definitions: definitions)
+    (var: Variable.t) : allocation_point =
+  match Variable.Tbl.find definitions.variable var with
+  | exception Not_found -> Variable var
+  | def ->
+    resolve_definition definitions var def
+
+and fetch_variable_field
+    (definitions: definitions)
+    (var: Variable.t)
+    (field: int) : allocation_point =
+  match Variable.Tbl.find definitions.variable var with
+  | Block (_, fields) ->
+    begin match List.nth fields field with
+    | exception Not_found ->
+      (* CR mshinwell for pchambart: Maybe we need to harden this module so that
+         it doesn't go wrong when compiling dead code?  (In the same way as
+         [Inline_and_simplify])? *)
+      Misc.fatal_errorf "No field %i in block %a" field Variable.print var
+    | v ->
+      fetch_variable definitions v
+    end
+  | exception Not_found ->
+    Misc.fatal_errorf "No definition for field access to %a" Variable.print var
+  | Symbol _ | Variable _ | Project_var _ | Field _ | Symbol_field _ ->
+    (* Must have been resolved *)
+    assert false
+  | Const _ | Allocated_const _
+  | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _ ->
+    Misc.fatal_errorf "Field access to %a which is not a block" Variable.print var
+
+and fetch_symbol_field
+    (definitions: definitions)
+    (sym: Symbol.t)
+    (field: int) : allocation_point =
+  match Symbol.Tbl.find definitions.symbol sym with
+  | Block (_, fields) ->
+    begin match List.nth fields field with
+    | exception Not_found ->
+      Misc.fatal_errorf "No field %i in block %a" field Symbol.print sym
+    | Symbol s ->
+      Symbol s
+    | Const _ ->
+      Symbol sym
+    end
+  | exception Not_found -> begin
+      match Symbol.Tbl.find definitions.initialize_symbol sym with
+      | fields -> begin
+          match List.nth fields field with
+          | None ->
+              Misc.fatal_errorf "field access to a not constant %a" Symbol.print sym
+          | Some v ->
+              fetch_variable definitions v
+        end
+      | exception Not_found ->
+          Misc.fatal_errorf "No definition for field access to %a" Symbol.print sym
+    end
+  | Allocated_const _ | Set_of_closures _ | Project_closure _ ->
+    Misc.fatal_errorf "Field access to %a which is not a block" Symbol.print sym
+
+let run variable initialize_symbol symbol =
+  let definitions = { variable; initialize_symbol; symbol; } in
+  Variable.Tbl.fold (fun var definition result ->
+      let definition = resolve_definition definitions var definition in
+      Variable.Map.add var definition result)
+    definitions.variable
+    Variable.Map.empty

middle_end/alias_analysis.mli

@@ -0,0 +1,56 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type allocation_point =
+  | Symbol of Symbol.t
+  | Variable of Variable.t
+
+type allocated_const =
+  | Normal of Allocated_const.t
+  | Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list
+  | Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t
+
+type constant_defining_value =
+  | Allocated_const of allocated_const
+  | Block of Tag.t * Variable.t list
+  | Set_of_closures of Flambda.set_of_closures
+  | Project_closure of Flambda.project_closure
+  | Move_within_set_of_closures of Flambda.move_within_set_of_closures
+  | Project_var of Flambda.project_var
+  | Field of Variable.t * int
+  | Symbol_field of Symbol.t * int
+  | Const of Flambda.const
+  | Symbol of Symbol.t
+  | Variable of Variable.t
+
+type initialize_symbol_field = Variable.t option
+
+(** Simple alias analysis working over information about which
+    symbols have been assigned to variables; and which constants have
+    been assigned to symbols.  The return value gives the assignment
+    of the defining values of constants to variables.
+    Also see comments for [Lift_constants], whose input feeds this
+    pass. *)
+val run
+   : constant_defining_value Variable.Tbl.t
+  -> initialize_symbol_field list Symbol.Tbl.t
+  -> Flambda.constant_defining_value Symbol.Tbl.t
+  -> allocation_point Variable.Map.t
+
+val print_constant_defining_value
+   : Format.formatter
+  -> constant_defining_value
+  -> unit

middle_end/allocated_const.ml

@@ -0,0 +1,83 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+  | Float of float
+  | Int32 of int32
+  | Int64 of int64
+  | Nativeint of nativeint
+  | Float_array of float list
+  | Immutable_float_array of float list
+  | String of string
+  | Immutable_string of string
+
+let compare (x : t) (y : t) =
+  let compare_floats x1 x2 =
+    (* It is important to compare the bit patterns here, so as not to
+       be subject to bugs such as GPR#295. *)
+    Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2)
+  in
+  let rec compare_float_lists l1 l2 =
+    match l1, l2 with
+    | [], [] -> 0
+    | [], _::_ -> -1
+    | _::_, [] -> 1
+    | h1::t1, h2::t2 ->
+      let c = compare_floats h1 h2 in
+      if c <> 0 then c else compare_float_lists t1 t2
+  in
+  match x, y with
+  | Float x, Float y -> compare_floats x y
+  | Int32 x, Int32 y -> compare x y
+  | Int64 x, Int64 y -> compare x y
+  | Nativeint x, Nativeint y -> compare x y
+  | Float_array x, Float_array y -> compare_float_lists x y
+  | Immutable_float_array x, Immutable_float_array y -> compare_float_lists x y
+  | String x, String y -> compare x y
+  | Immutable_string x, Immutable_string y -> compare x y
+  | Float _, _ -> -1
+  | _, Float _ -> 1
+  | Int32 _, _ -> -1
+  | _, Int32 _ -> 1
+  | Int64 _, _ -> -1
+  | _, Int64 _ -> 1
+  | Nativeint _, _ -> -1
+  | _, Nativeint _ -> 1
+  | Float_array _, _ -> -1
+  | _, Float_array _ -> 1
+  | Immutable_float_array _, _ -> -1
+  | _, Immutable_float_array _ -> 1
+  | String _, _ -> -1
+  | _, String _ -> 1
+
+let print ppf (t : t) =
+  let fprintf = Format.fprintf in
+  let floats ppf fl =
+    List.iter (fun f -> fprintf ppf "@ %f" f) fl
+  in
+  match t with
+  | String s -> fprintf ppf "%S" s
+  | Immutable_string s -> fprintf ppf "#%S" s
+  | Int32 n -> fprintf ppf "%lil" n
+  | Int64 n -> fprintf ppf "%LiL" n
+  | Nativeint n -> fprintf ppf "%nin" n
+  | Float f -> fprintf ppf "%f" f
+  | Float_array [] -> fprintf ppf "[| |]"
+  | Float_array (f1 :: fl) ->
+    fprintf ppf "@[<1>[|@[%f%a@]|]@]" f1 floats fl
+  | Immutable_float_array [] -> fprintf ppf "[|# |]"
+  | Immutable_float_array (f1 :: fl) ->
+    fprintf ppf "@[<1>[|# @[%f%a@]|]@]" f1 floats fl

middle_end/allocated_const.mli

@@ -0,0 +1,34 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Constants that are always allocated (possibly statically).  Blocks
+    are not included here since they are always encoded using
+    [Prim (Pmakeblock, ...)]. *)
+
+type t =
+  | Float of float
+  | Int32 of int32
+  | Int64 of int64
+  | Nativeint of nativeint
+  (* CR-someday mshinwell: consider using "float array" *)
+  | Float_array of float list
+  | Immutable_float_array of float list
+  | String of string
+  | Immutable_string of string
+
+val compare : t -> t -> int
+
+val print : Format.formatter -> t -> unit

middle_end/augment_closures.ml

@@ -0,0 +1,220 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+module A = Simple_value_approx
+module E = Inline_and_simplify_aux.Env
+
+type closures_in_free_vars =
+  {
+    new_var : Variable.t;
+    closure_id : Closure_id.t;
+    outside_var : Variable.t;
+  }
+
+type block_in_free_vars =
+  {
+    new_var : Variable.t;
+    outside_var : Variable.t;
+  }
+
+module Closure_field =
+  Identifiable.Make (Identifiable.Pair (Variable) (Var_within_closure))
+
+module Block_field =
+  Identifiable.Make (Identifiable.Pair (Variable) (Numbers.Int))
+
+let freshened_var env v =
+  Freshening.apply_variable (E.freshening env) v
+
+let closures_in_variables ~env map acc =
+  Variable.Map.fold (fun inside_var outside_var acc ->
+      let approx = E.find_exn env (freshened_var env outside_var) in
+      match A.check_approx_for_closure approx with
+      | Ok (value_closure, _approx_var, _approx_symbol,
+            value_set_of_closures) ->
+        Var_within_closure.Map.fold (fun bound_var _ (closure_acc, block_acc) ->
+            let new_var =
+              Variable.create (Var_within_closure.unique_name bound_var)
+            in
+            let closure_acc =
+              Closure_field.Map.add (inside_var, bound_var)
+                { new_var; closure_id = value_closure.closure_id; outside_var }
+                closure_acc
+            in
+            closure_acc, block_acc)
+          value_set_of_closures.bound_vars acc
+      | Wrong ->
+        match A.check_approx_for_block approx with
+        | Wrong ->
+          acc  (* Ignore free_vars that aren't closures or blocks. *)
+        | Ok (_tag, fields) ->
+          let closure_acc, block_acc = acc in
+          let block_acc = ref block_acc in
+          Array.iteri (fun i approx ->
+              (* CR-soon pchambart: should we restrict only to cases
+                 when the field is aliased to a variable outside
+                 of the closure (i.e. when we can certainly remove
+                 the allocation of the block) ?
+                 Note that this may prevent cases with imbricated
+                 closures from benefiting from this transformations.
+                 mshinwell: What word was "imbricated" supposed to be?
+              *)
+              match approx.A.var with
+              | Some v when E.mem env v ->
+                let new_var =
+                  Variable.create
+                    (Variable.unique_name inside_var ^ "_field_" ^ string_of_int i)
+                in
+                block_acc :=
+                  Block_field.Map.add (inside_var, i) { new_var; outside_var } !block_acc
+              | Some _ ->
+                ()
+              | _ -> ())
+            fields;
+          closure_acc, !block_acc)
+    map
+    acc
+
+let rewrite_set_of_closures
+    ~env
+    ~(set_of_closures:Flambda.set_of_closures) =
+  let elts_in_free_vars =
+    closures_in_variables ~env
+      set_of_closures.free_vars
+      (Closure_field.Map.empty, Block_field.Map.empty)
+  in
+  let elts_in_free_vars_and_specialised_args =
+    closures_in_variables ~env
+      set_of_closures.specialised_args
+      elts_in_free_vars
+  in
+  let closures_in_free_vars,
+      block_in_free_vars =
+    elts_in_free_vars_and_specialised_args
+  in
+  if Closure_field.Map.is_empty closures_in_free_vars
+    && Block_field.Map.is_empty block_in_free_vars
+  then
+    set_of_closures, Variable.Map.empty, Variable.Map.empty
+  else
+    let used_new_vars = Variable.Tbl.create 42 in
+    let rewrite_function_decl
+        (function_decl:Flambda.function_declaration) =
+      let body =
+        Flambda_iterators.map_toplevel_project_var_to_expr_opt
+          ~f:(fun project_var ->
+            match
+              Closure_field.Map.find
+                (project_var.closure, project_var.var)
+                closures_in_free_vars
+            with
+            | exception Not_found ->
+              None
+            | { new_var } ->
+              Variable.Tbl.add used_new_vars new_var ();
+              Some (Flambda.Var new_var))
+          function_decl.body
+      in
+      let body =
+        Flambda_iterators.map_toplevel_named (function
+            | (Prim (Pfield i, [v], _)) when
+                Block_field.Map.mem (v, i) block_in_free_vars ->
+              let { new_var } = Block_field.Map.find (v, i) block_in_free_vars in
+              Variable.Tbl.add used_new_vars new_var ();
+              Expr (Var new_var)
+            | named ->
+              named)
+          body
+      in
+      Flambda.create_function_declaration
+        ~body
+        ~inline:function_decl.inline
+        ~params:function_decl.params
+        ~stub:function_decl.stub
+        ~dbg:function_decl.dbg
+        ~is_a_functor:function_decl.is_a_functor
+    in
+    let funs =
+      Variable.Map.map
+        rewrite_function_decl
+        set_of_closures.function_decls.funs
+    in
+    let function_decls =
+      Flambda.update_function_declarations ~funs
+        set_of_closures.function_decls
+    in
+    let free_vars, add_closures =
+      Closure_field.Map.fold
+        (fun (_var, field) { new_var; closure_id; outside_var } (free_vars, add_closures) ->
+           let intermediate_var =
+             Variable.rename new_var
+           in
+           if Variable.Tbl.mem used_new_vars new_var then
+             Variable.Map.add new_var intermediate_var free_vars,
+             Variable.Map.add intermediate_var
+               (Flambda.Project_var { Flambda.closure = outside_var; closure_id; var = field })
+               add_closures
+           else
+             free_vars, add_closures)
+        closures_in_free_vars
+        (set_of_closures.free_vars,
+         Variable.Map.empty)
+    in
+    let free_vars, add_blocks =
+      Block_field.Map.fold
+        (fun (_var, field) { new_var; outside_var } (free_vars, add_blocks) ->
+           let intermediate_var =
+             Variable.rename new_var
+           in
+           if Variable.Tbl.mem used_new_vars new_var then
+             Variable.Map.add new_var intermediate_var free_vars,
+             Variable.Map.add intermediate_var
+               (Flambda.Prim (Pfield field, [outside_var], Debuginfo.none))
+               add_blocks
+           else
+             free_vars, add_blocks)
+        block_in_free_vars
+        (free_vars,
+         Variable.Map.empty)
+    in
+    Flambda.create_set_of_closures
+      ~function_decls
+      ~free_vars
+      ~specialised_args:set_of_closures.specialised_args,
+    add_closures, add_blocks
+
+let run ~env ~(set_of_closures:Flambda.set_of_closures) : Flambda.t option =
+  if !Clflags.classic_inlining then None
+  else
+    let set_of_closures, add_closures, add_blocks =
+      rewrite_set_of_closures
+        ~env ~set_of_closures
+    in
+    if Variable.Map.is_empty add_closures &&
+       Variable.Map.is_empty add_blocks then
+      None
+    else
+      let expr =
+        Variable.Map.fold Flambda.create_let
+          add_closures
+            (Flambda_utils.name_expr (Set_of_closures set_of_closures)
+              ~name:"augment_closure")
+      in
+      let expr =
+        Variable.Map.fold Flambda.create_let
+          add_blocks expr
+      in
+      Some expr

middle_end/augment_closures.mli

@@ -0,0 +1,21 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+val run :
+  env:Inline_and_simplify_aux.Env.t ->
+  set_of_closures:Flambda.set_of_closures ->
+  Flambda.t option
+

middle_end/backend_intf.mli

@@ -0,0 +1,45 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Knowledge that the middle end needs about the backend. *)
+
+module type S = sig
+  (** Compute the symbol for the given identifier. *)
+  val symbol_for_global' : (Ident.t -> Symbol.t)
+
+  (** If the given approximation is that of a symbol (Value_symbol) or an
+      external (Value_extern), attempt to find a more informative
+      approximation from a previously-written compilation artifact.  In the
+      native code backend, for example, this might consult a .cmx file. *)
+  val really_import_approx : Simple_value_approx.t -> Simple_value_approx.t
+
+  val import_symbol : Symbol.t -> Simple_value_approx.t
+
+  val closure_symbol : Closure_id.t -> Symbol.t
+
+  (** The natural size of an integer on the target architecture
+      (cf. [Arch.size_int] in the native code backend). *)
+  val size_int : int
+
+  (** [true] iff the target architecture is big endian. *)
+  val big_endian : bool
+
+  (** The maximum number of arguments that is is reasonable for a function
+      to have.  This should be fewer than the threshold that causes non-self
+      tail call optimization to be inhibited (in particular, if it would
+      entail passing arguments on the stack; see [Selectgen]). *)
+  val max_sensible_number_of_arguments : int
+end

middle_end/base_types/closure_element.ml

@@ -0,0 +1,22 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+include Variable
+
+let wrap t = t
+let unwrap t = t
+
+let wrap_map t = t

middle_end/base_types/closure_element.mli

@@ -0,0 +1,29 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+include Identifiable.S
+
+val wrap : Variable.t -> t
+val unwrap : t -> Variable.t
+
+val wrap_map : 'a Variable.Map.t -> 'a Map.t
+
+val in_compilation_unit : t -> Compilation_unit.t -> bool
+val get_compilation_unit : t -> Compilation_unit.t
+
+val unique_name : t -> string
+
+val output_full : out_channel -> t -> unit

middle_end/base_types/closure_id.ml

@@ -0,0 +1,17 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+include Closure_element

middle_end/base_types/closure_id.mli

@@ -0,0 +1,24 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** CR-someday lwhite: "Closure_id" is quite a generic name. I wonder wether something
+    like "Closure_label" would better capture that it is the label of a projection. *)
+
+(** An identifier, unique across the whole program (not just one compilation
+    unit), that identifies a closure within a particular set of closures
+    (viz. [Project_closure]). *)
+
+include module type of Closure_element

middle_end/base_types/compilation_unit.ml

@@ -0,0 +1,71 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t = {
+  id : Ident.t;
+  linkage_name : Linkage_name.t;
+  hash : int;
+}
+
+let string_for_printing t = Ident.name t.id
+
+include Identifiable.Make (struct
+  type nonrec t = t
+
+  (* Multiple units can have the same [id] if they come from different packs.
+     To distinguish these we also keep the linkage name, which contains the
+     name of the pack. *)
+  let compare v1 v2 =
+    if v1 == v2 then 0
+    else
+      let c = compare v1.hash v2.hash in
+      if c = 0 then
+        let v1_id = Ident.name v1.id in
+        let v2_id = Ident.name v2.id in
+        let c = String.compare v1_id v2_id in
+        if c = 0 then
+          Linkage_name.compare v1.linkage_name v2.linkage_name
+        else
+          c
+      else c
+
+  let equal x y =
+    if x == y then true
+    else compare x y = 0
+
+  let print ppf t = Format.pp_print_string ppf (string_for_printing t)
+
+  let output oc x = output_string oc (Ident.name x.id)
+  let hash x = x.hash
+end)
+
+let create (id : Ident.t) linkage_name =
+  if not (Ident.persistent id) then begin
+    Misc.fatal_error "Compilation_unit.create with non-persistent Ident.t"
+  end;
+  { id; linkage_name; hash = Hashtbl.hash id.name }
+
+let get_persistent_ident cu = cu.id
+let get_linkage_name cu = cu.linkage_name
+
+let current = ref None
+let set_current t = current := Some t
+let get_current () = !current
+let get_current_exn () =
+  match !current with
+  | Some current -> current
+  | None -> Misc.fatal_error "Compilation_unit.get_current_exn"
+let get_current_id_exn () = get_persistent_ident (get_current_exn ())

middle_end/base_types/compilation_unit.mli

@@ -0,0 +1,31 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+include Identifiable.S
+
+(* The [Ident.t] must be persistent.  This function raises an exception
+   if that is not the case. *)
+val create : Ident.t -> Linkage_name.t -> t
+
+val get_persistent_ident : t -> Ident.t
+val get_linkage_name : t -> Linkage_name.t
+
+val set_current : t -> unit
+val get_current : unit -> t option
+val get_current_exn : unit -> t
+val get_current_id_exn : unit -> Ident.t
+
+val string_for_printing : t -> string

middle_end/base_types/export_id.ml

@@ -0,0 +1,26 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Id : Id_types.Id = Id_types.Id (struct end)
+module Unit_id = Id_types.UnitId (Id) (Compilation_unit)
+
+type t = Unit_id.t
+
+include Identifiable.Make (Unit_id)
+
+let create = Unit_id.create
+let get_compilation_unit = Unit_id.unit
+let name = Unit_id.name

middle_end/base_types/export_id.mli

@@ -0,0 +1,26 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Keys representing value descriptions that may be written into
+   intermediate files and loaded by a dependent compilation unit.
+   These keys are used to ensure maximal sharing of value descriptions,
+   which may be substantial. *)
+
+include Identifiable.S
+
+val create : ?name:string -> Compilation_unit.t -> t
+val name : t -> string option
+val get_compilation_unit : t -> Compilation_unit.t

middle_end/base_types/id_types.ml

@@ -0,0 +1,90 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+module type BaseId = sig
+  type t
+  val equal : t -> t -> bool
+  val compare : t -> t -> int
+  val hash : t -> int
+  val name : t -> string option
+  val to_string : t -> string
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+end
+
+module type Id = sig
+  include BaseId
+  val create : ?name:string -> unit -> t
+end
+
+module type UnitId = sig
+  module Compilation_unit : Identifiable.Thing
+  include BaseId
+  val create : ?name:string -> Compilation_unit.t -> t
+  val unit : t -> Compilation_unit.t
+end
+
+module Id(E:sig end) : Id = struct
+  type t = int * string
+  let empty_string = ""
+  let create = let r = ref 0 in
+    fun  ?(name=empty_string) () -> incr r; !r, name
+  let equal (t1,_) (t2,_) = (t1:int) = t2
+  let compare (t1,_) (t2,_) = t1 - t2
+  let hash (t,_) = t
+  let name (_,name) =
+    if name == empty_string
+    then None
+    else Some name
+  let to_string (t,name) =
+    if name == empty_string
+    then string_of_int t
+    else Printf.sprintf "%s_%i" name t
+  let output fd t = output_string fd (to_string t)
+  let print ppf v = Format.pp_print_string ppf (to_string v)
+end
+
+module UnitId(Innerid:Id)(Compilation_unit:Identifiable.Thing) :
+  UnitId with module Compilation_unit := Compilation_unit = struct
+  type t = {
+    id : Innerid.t;
+    unit : Compilation_unit.t;
+  }
+  let compare x y =
+    let c = Innerid.compare x.id y.id in
+    if c <> 0
+    then c
+    else Compilation_unit.compare x.unit y.unit
+  let output oc x =
+    Printf.fprintf oc "%a.%a"
+      Compilation_unit.output x.unit
+      Innerid.output x.id
+  let print ppf x =
+    Format.fprintf ppf "%a.%a"
+      Compilation_unit.print x.unit
+      Innerid.print x.id
+  let hash off = Hashtbl.hash off
+  let equal o1 o2 = compare o1 o2 = 0
+  let name o = Innerid.name o.id
+  let to_string x =
+    Format.asprintf "%a.%a"
+      Compilation_unit.print x.unit
+      Innerid.print x.id
+  let create ?name unit =
+    let id = Innerid.create ?name () in
+    { id; unit }
+  let unit x = x.unit
+end

middle_end/base_types/id_types.mli

@@ -0,0 +1,57 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* CR-soon mshinwell: This module should be removed. *)
+
+
+
+(** Generic identifier type *)
+module type BaseId =
+sig
+  type t
+  val equal : t -> t -> bool
+  val compare : t -> t -> int
+  val hash : t -> int
+  val name : t -> string option
+  val to_string : t -> string
+  val output : out_channel -> t -> unit
+  val print : Format.formatter -> t -> unit
+end
+
+module type Id =
+sig
+  include BaseId
+  val create : ?name:string -> unit -> t
+end
+
+(** Fully qualified identifiers *)
+module type UnitId =
+sig
+  module Compilation_unit : Identifiable.Thing
+  include BaseId
+  val create : ?name:string -> Compilation_unit.t -> t
+  val unit : t -> Compilation_unit.t
+end
+
+(** If applied generatively, i.e. [Id(struct end)], creates a new type
+    of identifiers. *)
+module Id : functor (E : sig end) -> Id
+
+module UnitId :
+  functor (Id : Id) ->
+  functor (Compilation_unit : Identifiable.Thing) ->
+    UnitId with module Compilation_unit := Compilation_unit
+

middle_end/base_types/linkage_name.ml

@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t = string
+
+include Identifiable.Make (struct
+  include String
+  let hash = Hashtbl.hash
+  let print ppf t = Format.pp_print_string ppf t
+  let output chan t = output_string chan t
+end)
+
+let create t = t
+let to_string t = t

middle_end/base_types/linkage_name.mli

@@ -0,0 +1,20 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+include Identifiable.S
+
+val create : string -> t
+val to_string : t -> string

middle_end/base_types/mutable_variable.ml

@@ -0,0 +1,89 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t = {
+  compilation_unit : Compilation_unit.t;
+  ident : Ident.t;
+}
+
+include Identifiable.Make (struct
+  type nonrec t = t
+
+  let compare v1 v2 =
+    let c = Ident.compare v1.ident v2.ident in
+    if c = 0
+    then Compilation_unit.compare v1.compilation_unit v2.compilation_unit
+    else c
+
+  let output c v = Ident.output c v.ident
+
+  let hash v = Ident.hash v.ident
+
+  let equal v1 v2 =
+    Ident.same v1.ident v2.ident &&
+    Compilation_unit.equal v1.compilation_unit v2.compilation_unit
+
+  let print ppf v =
+    Format.fprintf ppf "%a.%a"
+      Compilation_unit.print v.compilation_unit
+      Ident.print v.ident
+end)
+
+let create ?current_compilation_unit name =
+  let compilation_unit =
+    match current_compilation_unit with
+    | Some compilation_unit -> compilation_unit
+    | None -> Compilation_unit.get_current_exn ()
+  in
+  { compilation_unit;
+    ident = Ident.create name;
+  }
+
+let of_ident ident = create (Ident.name ident)
+
+let unique_ident t =
+  { t.ident with
+    name =
+      Format.asprintf "%a_%s"
+        Compilation_unit.print t.compilation_unit
+        t.ident.name;
+  }
+
+let rename ?current_compilation_unit ?append t =
+  let compilation_unit =
+    match current_compilation_unit with
+    | Some compilation_unit -> compilation_unit
+    | None -> Compilation_unit.get_current_exn ()
+  in
+  let ident =
+    match append with
+    | None -> Ident.rename t.ident
+    | Some s -> Ident.create (t.ident.Ident.name ^ s)
+  in
+  { compilation_unit = compilation_unit;
+    ident;
+  }
+
+let freshen t =
+  rename t ~current_compilation_unit:(Compilation_unit.get_current_exn ())
+
+let in_compilation_unit t cu =
+  Compilation_unit.equal t.compilation_unit cu
+
+let output_full c t =
+  Compilation_unit.output c t.compilation_unit;
+  Printf.fprintf c ".";
+  Ident.output c t.ident

middle_end/base_types/mutable_variable.mli

@@ -0,0 +1,35 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+include Identifiable.S
+
+val create : ?current_compilation_unit:Compilation_unit.t -> string -> t
+val of_ident : Ident.t -> t
+
+(** For [Flambda_to_clambda] only. *)
+val unique_ident : t -> Ident.t
+
+val freshen : t -> t
+
+val rename
+   : ?current_compilation_unit:Compilation_unit.t
+  -> ?append:string
+  -> t
+  -> t
+
+val in_compilation_unit : t -> Compilation_unit.t -> bool
+
+val output_full : out_channel -> t -> unit

middle_end/base_types/set_of_closures_id.ml

@@ -0,0 +1,25 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Id : Id_types.Id = Id_types.Id (struct end)
+module Unit_id = Id_types.UnitId (Id) (Compilation_unit)
+
+type t = Unit_id.t
+
+include Identifiable.Make (Unit_id)
+
+let create = Unit_id.create
+let get_compilation_unit = Unit_id.unit

middle_end/base_types/set_of_closures_id.mli

@@ -0,0 +1,23 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** An identifier, unique across the whole program, that identifies a set
+    of a closures (viz. [Set_of_closures]). *)
+
+include Identifiable.S
+
+val create : ?name:string -> Compilation_unit.t -> t
+val get_compilation_unit : t -> Compilation_unit.t

middle_end/base_types/static_exception.ml

@@ -0,0 +1,20 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+include Numbers.Int
+
+let create () = Lambda.next_raise_count ()
+let to_int t = t

middle_end/base_types/static_exception.mli

@@ -0,0 +1,24 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** An identifier that is used to label static exceptions.  Its
+    uniqueness properties are unspecified. *)
+
+include Identifiable.S
+
+val create : unit -> t
+
+val to_int : t -> int

middle_end/base_types/symbol.ml

@@ -0,0 +1,75 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t = {
+  compilation_unit : Compilation_unit.t;
+  label : Linkage_name.t;
+  hash : int;
+}
+
+include Identifiable.Make (struct
+  type nonrec t = t
+
+  let compare t1 t2 =
+    (* Linkage names are unique across a whole project, so just comparing
+       those is sufficient. *)
+    if t1 == t2 then 0
+    else
+      let c = compare t1.hash t2.hash in
+      if c <> 0 then c
+      else Linkage_name.compare t1.label t2.label
+
+  let equal x y =
+    if x == y then true
+    else compare x y = 0
+
+  let output chan t = Linkage_name.output chan t.label
+
+  let hash t = t.hash
+
+  let print ppf t =
+    Compilation_unit.print ppf t.compilation_unit;
+    Format.pp_print_string ppf ".";
+    Linkage_name.print ppf t.label
+end)
+
+let create compilation_unit label =
+  let unit_linkage_name =
+    Linkage_name.to_string
+      (Compilation_unit.get_linkage_name compilation_unit)
+  in
+  let label =
+    Linkage_name.create (unit_linkage_name ^ "__" ^ (Linkage_name.to_string label))
+  in
+  let hash = Linkage_name.hash label in
+  { compilation_unit; label; hash; }
+
+let unsafe_create compilation_unit label =
+  let hash = Linkage_name.hash label in
+  { compilation_unit; label; hash; }
+
+let import_for_pack ~pack:compilation_unit symbol =
+  let hash = Linkage_name.hash symbol.label in
+  { compilation_unit; label = symbol.label; hash; }
+
+let compilation_unit t = t.compilation_unit
+let label t = t.label
+
+let print_opt ppf = function
+  | None -> Format.fprintf ppf "<no symbol>"
+  | Some t -> print ppf t
+
+let compare_lists l1 l2 = Misc.compare_lists compare l1 l2

middle_end/base_types/symbol.mli

@@ -0,0 +1,41 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** A symbol identifies a constant provided by either:
+    - another compilation unit; or
+    - a top-level module.
+
+    * [sym_unit] is the compilation unit containing the value.
+    * [sym_label] is the linkage name of the variable.
+
+    The label must be globally unique: two compilation units linked in the
+    same program must not share labels. *)
+
+include Identifiable.S
+
+val create : Compilation_unit.t -> Linkage_name.t -> t
+(* Create the symbol without prefixing with the compilation unit.
+   Used for predefined exceptions *)
+val unsafe_create : Compilation_unit.t -> Linkage_name.t -> t
+
+val import_for_pack : pack:Compilation_unit.t -> t -> t
+
+val compilation_unit : t -> Compilation_unit.t
+val label : t -> Linkage_name.t
+
+val print_opt : Format.formatter -> t option -> unit
+
+val compare_lists : t list -> t list -> int

middle_end/base_types/tag.ml

@@ -0,0 +1,30 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t = int
+
+include Identifiable.Make (Numbers.Int)
+
+let create_exn tag =
+  if tag < 0 || tag > 255 then
+    Misc.fatal_error (Printf.sprintf "Tag.create_exn %d" tag)
+  else
+    tag
+
+let to_int t = t
+
+let zero = 0
+let object_tag = Obj.object_tag

middle_end/base_types/tag.mli

@@ -0,0 +1,25 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Tags on runtime boxed values. *)
+
+include Identifiable.S
+
+val create_exn : int -> t
+val to_int : t -> int
+
+val zero : t
+val object_tag : t

middle_end/base_types/var_within_closure.ml

@@ -0,0 +1,17 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+include Closure_element

middle_end/base_types/var_within_closure.mli

@@ -0,0 +1,22 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** An identifier, unique across the whole program, that identifies a
+    particular variable within a particular closure.  Only
+    [Project_var], and not [Var], nodes are tagged with these
+    identifiers. *)
+
+include module type of Closure_element

middle_end/base_types/variable.ml

@@ -0,0 +1,121 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t = {
+  compilation_unit : Compilation_unit.t;
+  name : string;
+  name_stamp : int;
+  (** [name_stamp]s are unique within any given compilation unit. *)
+}
+
+include Identifiable.Make (struct
+  type nonrec t = t
+
+  let compare t1 t2 =
+    if t1 == t2 then 0
+    else
+      let c = t1.name_stamp - t2.name_stamp in
+      if c <> 0 then c
+      else Compilation_unit.compare t1.compilation_unit t2.compilation_unit
+
+  let equal t1 t2 =
+    if t1 == t2 then true
+    else
+      t1.name_stamp = t2.name_stamp
+        && Compilation_unit.equal t1.compilation_unit t2.compilation_unit
+
+  let output chan t =
+    output_string chan t.name;
+    output_string chan "_";
+    output_string chan (string_of_int t.name_stamp)
+
+  let hash t = t.name_stamp lxor (Compilation_unit.hash t.compilation_unit)
+
+  let print ppf t =
+    if Compilation_unit.equal t.compilation_unit
+        (Compilation_unit.get_current_exn ())
+    then begin
+      Format.fprintf ppf "%s/%d"
+        t.name t.name_stamp
+    end else begin
+      Format.fprintf ppf "%a.%s/%d"
+        Compilation_unit.print t.compilation_unit
+        t.name t.name_stamp
+    end
+end)
+
+let previous_name_stamp = ref (-1)
+
+let create ?current_compilation_unit name =
+  let compilation_unit =
+    match current_compilation_unit with
+    | Some compilation_unit -> compilation_unit
+    | None -> Compilation_unit.get_current_exn ()
+  in
+  let name_stamp =
+    incr previous_name_stamp;
+    !previous_name_stamp
+  in
+  { compilation_unit;
+    name;
+    name_stamp;
+  }
+
+let create_with_same_name_as_ident ident = create (Ident.name ident)
+
+let clambda_name t =
+  (Compilation_unit.string_for_printing t.compilation_unit) ^ "_" ^ t.name
+
+let rename ?current_compilation_unit ?append t =
+  let current_compilation_unit =
+    match current_compilation_unit with
+    | Some compilation_unit -> compilation_unit
+    | None -> Compilation_unit.get_current_exn ()
+  in
+  let name =
+    match append with
+    | None -> t.name
+    | Some s -> t.name ^ s
+  in
+  create ~current_compilation_unit name
+
+let in_compilation_unit t cu =
+  Compilation_unit.equal cu t.compilation_unit
+
+let get_compilation_unit t = t.compilation_unit
+
+let unique_name t =
+  t.name ^ "_" ^ (string_of_int t.name_stamp)
+
+let print_list ppf ts =
+  List.iter (fun t -> Format.fprintf ppf "@ %a" print t) ts
+
+let debug_when_stamp_matches t ~stamp ~f =
+  if t.name_stamp = stamp then f ()
+
+let print_opt ppf = function
+  | None -> Format.fprintf ppf "<no var>"
+  | Some t -> print ppf t
+
+type pair = t * t
+module Pair = Identifiable.Make (Identifiable.Pair (T) (T))
+
+let compare_lists l1 l2 = Misc.compare_lists compare l1 l2
+
+let output_full chan t =
+  Compilation_unit.output chan t.compilation_unit;
+  output_string chan ".";
+  output chan t

middle_end/base_types/variable.mli

@@ -0,0 +1,60 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** [Variable.t] is the equivalent of a non-persistent [Ident.t] in
+    the [Flambda] tree.  It wraps an [Ident.t] together with its source
+    [compilation_unit].  As such, it is unique within a whole program,
+    not just one compilation unit.
+
+    Introducing a new type helps in tracing the source of identifiers
+    when debugging the inliner.  It also avoids Ident renaming when
+    importing cmx files.
+*)
+
+include Identifiable.S
+
+val create : ?current_compilation_unit:Compilation_unit.t -> string -> t
+val create_with_same_name_as_ident : Ident.t -> t
+
+val clambda_name : t -> string
+(* CR-someday pchambart: Should we propagate Variable.t into clambda ??? *)
+
+val rename
+   : ?current_compilation_unit:Compilation_unit.t
+  -> ?append:string
+  -> t
+  -> t
+
+val in_compilation_unit : t -> Compilation_unit.t -> bool
+
+val unique_name : t -> string
+
+val get_compilation_unit : t -> Compilation_unit.t
+
+val print_list : Format.formatter -> t list -> unit
+val print_opt : Format.formatter -> t option -> unit
+
+(** If the given variable has the given stamp, call the user-supplied
+    function.  For debugging purposes only. *)
+val debug_when_stamp_matches : t -> stamp:int -> f:(unit -> unit) -> unit
+
+type pair = t * t
+module Pair : Identifiable.S with type t := pair
+
+val compare_lists : t list -> t list -> int
+
+val output_full : out_channel -> t -> unit
+(** Unlike [output], [output_full] includes the compilation unit. *)

middle_end/closure_conversion.ml

@@ -0,0 +1,603 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Env = Closure_conversion_aux.Env
+module Function_decls = Closure_conversion_aux.Function_decls
+module Function_decl = Function_decls.Function_decl
+module IdentSet = Lambda.IdentSet
+
+let name_expr = Flambda_utils.name_expr
+
+type t = {
+  current_unit_id : Ident.t;
+  symbol_for_global' : (Ident.t -> Symbol.t);
+  mutable imported_symbols : Symbol.Set.t;
+}
+
+(** Generate a wrapper ("stub") function that accepts a tuple argument and
+    calls another function with arguments extracted in the obvious
+    manner from the tuple. *)
+let tupled_function_call_stub original_params unboxed_version
+      : Flambda.function_declaration =
+  let tuple_param =
+    Variable.rename ~append:"tupled_stub_param" unboxed_version
+  in
+  let params = List.map (fun p -> Variable.rename p) original_params in
+  let call : Flambda.t =
+    Apply ({
+        func = unboxed_version;
+        args = params;
+        (* CR-someday mshinwell for mshinwell: investigate if there is some
+           redundancy here (func is also unboxed_version) *)
+        kind = Direct (Closure_id.wrap unboxed_version);
+        dbg = Debuginfo.none;
+        inline = Default_inline;
+      })
+  in
+  let _, body =
+    List.fold_left (fun (pos, body) param ->
+        let lam : Flambda.named =
+          Prim (Pfield pos, [tuple_param], Debuginfo.none)
+        in
+        pos + 1, Flambda.create_let param lam body)
+      (0, call) params
+  in
+  Flambda.create_function_declaration ~params:[tuple_param]
+    ~body ~stub:true ~dbg:Debuginfo.none ~inline:Default_inline
+    ~is_a_functor:false
+
+(** Propagate an [Lev_after] debugging event into an adjacent Flambda node. *)
+let add_debug_info (ev : Lambda.lambda_event) (flam : Flambda.t)
+      : Flambda.t =
+  match ev.lev_kind with
+  | Lev_after _ ->
+    begin match flam with
+    | Apply ap ->
+      Apply { ap with dbg = Debuginfo.from_call ev; }
+    | Let let_expr ->
+      Flambda.map_defining_expr_of_let let_expr ~f:(function
+        | Prim (p, args, _dinfo) ->
+          Prim (p, args, Debuginfo.from_call ev)
+        | defining_expr -> defining_expr)
+    | Send { kind; meth; obj; args; dbg = _; } ->
+      Send { kind; meth; obj; args; dbg = Debuginfo.from_call ev; }
+    | _ -> flam
+    end
+  | _ -> flam
+
+let rec eliminate_const_block (const : Lambda.structured_constant)
+      : Lambda.lambda =
+  match const with
+  | Const_block (tag, consts) ->
+    Lprim (Pmakeblock (tag, Asttypes.Immutable),
+      List.map eliminate_const_block consts)
+  | Const_base _
+  | Const_pointer _
+  | Const_immstring _
+  | Const_float_array _ -> Lconst const
+
+let rec close_const t env (const : Lambda.structured_constant)
+      : Flambda.named * string =
+  match const with
+  | Const_base (Const_int c) -> Const (Int c), "int"
+  | Const_base (Const_char c) -> Const (Char c), "char"
+  | Const_base (Const_string (s, _)) -> Allocated_const (String s), "string"
+  | Const_base (Const_float c) ->
+    Allocated_const (Float (float_of_string c)), "float"
+  | Const_base (Const_int32 c) -> Allocated_const (Int32 c), "int32"
+  | Const_base (Const_int64 c) -> Allocated_const (Int64 c), "int64"
+  | Const_base (Const_nativeint c) ->
+    Allocated_const (Nativeint c), "nativeint"
+  | Const_pointer c -> Const (Const_pointer c), "pointer"
+  | Const_immstring c -> Allocated_const (Immutable_string c), "immstring"
+  | Const_float_array c ->
+    Allocated_const (Float_array (List.map float_of_string c)), "float_array"
+  | Const_block _ ->
+    Expr (close t env (eliminate_const_block const)), "const_block"
+
+and close t env (lam : Lambda.lambda) : Flambda.t =
+  match lam with
+  | Lvar id ->
+    begin match Env.find_var_exn env id with
+    | var -> Var var
+    | exception Not_found ->
+      match Env.find_mutable_var_exn env id with
+      | mut_var -> name_expr (Read_mutable mut_var) ~name:"read_mutable"
+      | exception Not_found ->
+        Misc.fatal_errorf "Closure_conversion.close: unbound identifier %a"
+          Ident.print id
+    end
+  | Lconst cst ->
+    let cst, name = close_const t env cst in
+    name_expr cst ~name:("const_" ^ name)
+  | Llet ((Strict | Alias | StrictOpt), id, defining_expr, body) ->
+    let var = Variable.create_with_same_name_as_ident id in
+    let defining_expr = close_let_bound_expression t var env defining_expr in
+    let body = close t (Env.add_var env id var) body in
+    Flambda.create_let var defining_expr body
+  | Llet (Variable, id, defining_expr, body) ->
+    let mut_var = Mutable_variable.of_ident id in
+    let var = Variable.create_with_same_name_as_ident id in
+    let defining_expr = close_let_bound_expression t var env defining_expr in
+    let body = close t (Env.add_mutable_var env id mut_var) body in
+    Flambda.create_let var defining_expr (Let_mutable (mut_var, var, body))
+  | Lfunction { kind; params; body; attr; } ->
+    let name =
+      (* Name anonymous functions by their source location, if known. *)
+      match body with
+      | Levent (_, { lev_loc }) ->
+        Format.asprintf "anon-fn[%a]" Location.print_compact lev_loc
+      | _ -> "anon-fn"
+    in
+    let closure_bound_var = Variable.create name in
+    (* CR-soon mshinwell: some of this is now very similar to the let rec case
+       below *)
+    let set_of_closures_var = Variable.create ("set_of_closures_" ^ name) in
+    let set_of_closures =
+      let decl =
+        Function_decl.create ~let_rec_ident:None ~closure_bound_var ~kind
+          ~params ~body ~inline:attr.inline ~is_a_functor:attr.is_a_functor
+      in
+      close_functions t env (Function_decls.create [decl])
+    in
+    let project_closure : Flambda.project_closure =
+      { set_of_closures = set_of_closures_var;
+        closure_id = Closure_id.wrap closure_bound_var;
+      }
+    in
+    Flambda.create_let set_of_closures_var set_of_closures
+      (name_expr (Project_closure (project_closure))
+        ~name:("project_closure_" ^ name))
+  | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall = _;
+        ap_inlined; } ->
+    Lift_code.lifting_helper (close_list t env ap_args)
+      ~evaluation_order:`Right_to_left
+      ~name:"apply_arg"
+      ~create_body:(fun args ->
+        let func = close t env ap_func in
+        let func_var = Variable.create "apply_funct" in
+        Flambda.create_let func_var (Expr func)
+          (Apply ({
+              func = func_var;
+              args;
+              kind = Indirect;
+              dbg = Debuginfo.from_location Dinfo_call ap_loc;
+              inline = ap_inlined;
+            })))
+  | Lletrec (defs, body) ->
+    let env =
+      List.fold_right (fun (id,  _) env ->
+          Env.add_var env id (Variable.create_with_same_name_as_ident id))
+        defs env
+    in
+    let function_declarations =
+      (* Identify any bindings in the [let rec] that are functions.  These
+         will be named after the corresponding identifier in the [let rec]. *)
+      List.map (function
+          | (let_rec_ident, Lambda.Lfunction { kind; params; body; attr; }) ->
+            let closure_bound_var =
+              Variable.create_with_same_name_as_ident let_rec_ident
+            in
+            let function_declaration =
+              Function_decl.create ~let_rec_ident:(Some let_rec_ident)
+                ~closure_bound_var ~kind ~params ~body
+                ~inline:attr.inline ~is_a_functor:attr.is_a_functor
+            in
+            Some function_declaration
+          | _ -> None)
+        defs
+    in
+    begin match Misc.some_if_all_elements_are_some function_declarations with
+    | Some function_declarations ->
+      (* When all the bindings are (syntactically) functions, we can
+         eliminate the [let rec] construction, instead producing a normal
+         [Let] that binds a set of closures containing all of the functions.
+      *)
+      (* CR-someday lwhite: This is a very syntactic criteria. Adding an
+         unused value to a set of recursive bindings changes how
+         functions are represented at runtime. *)
+      let name =
+        (* The Microsoft assembler has a 247-character limit on symbol
+           names, so we keep them shorter to try not to hit this. *)
+        if Sys.win32 then begin
+          match defs with
+          | (id, _)::_ -> (Ident.unique_name id) ^ "_let_rec"
+          | _ -> "let_rec"
+        end else begin
+          String.concat "_and_"
+            (List.map (fun (id, _) -> Ident.unique_name id) defs)
+        end
+      in
+      let set_of_closures_var = Variable.create name in
+      let set_of_closures =
+        close_functions t env (Function_decls.create function_declarations)
+      in
+      let body =
+        List.fold_left (fun body decl ->
+            let let_rec_ident = Function_decl.let_rec_ident decl in
+            let closure_bound_var = Function_decl.closure_bound_var decl in
+            let let_bound_var = Env.find_var env let_rec_ident in
+            (* Inside the body of the [let], each function is referred to by
+               a [Project_closure] expression, which projects from the set of
+               closures. *)
+            (Flambda.create_let let_bound_var
+              (Project_closure {
+                set_of_closures = set_of_closures_var;
+                closure_id = Closure_id.wrap closure_bound_var;
+              })
+              body))
+          (close t env body) function_declarations
+      in
+      Flambda.create_let set_of_closures_var set_of_closures body
+    | None ->
+      (* If the condition above is not satisfied, we build a [Let_rec]
+         expression; any functions bound by it will have their own
+         individual closures. *)
+      let defs =
+        List.map (fun (id, def) ->
+            let var = Env.find_var env id in
+            var, close_let_bound_expression t ~let_rec_ident:id var env def)
+          defs
+      in
+      Let_rec (defs, close t env body)
+    end
+  | Lsend (kind, meth, obj, args, loc) ->
+    let meth_var = Variable.create "meth" in
+    let obj_var = Variable.create "obj" in
+    let dbg = Debuginfo.from_location Dinfo_call loc in
+    Flambda.create_let meth_var (Expr (close t env meth))
+      (Flambda.create_let obj_var (Expr (close t env obj))
+        (Lift_code.lifting_helper (close_list t env args)
+          ~evaluation_order:`Right_to_left
+          ~name:"send_arg"
+          ~create_body:(fun args ->
+              Send { kind; meth = meth_var; obj = obj_var; args; dbg; })))
+  | Lprim ((Pdivint | Pmodint) as prim, [arg1; arg2])
+      when not !Clflags.fast -> (* not -unsafe *)
+    let arg2 = close t env arg2 in
+    let arg1 = close t env arg1 in
+    let numerator = Variable.create "numerator" in
+    let denominator = Variable.create "denominator" in
+    let zero = Variable.create "zero" in
+    let is_zero = Variable.create "is_zero" in
+    let exn = Variable.create "division_by_zero" in
+    let exn_symbol =
+      t.symbol_for_global' Predef.ident_division_by_zero
+    in
+    t.imported_symbols <- Symbol.Set.add exn_symbol t.imported_symbols;
+    Flambda.create_let zero (Const (Int 0))
+      (Flambda.create_let exn (Symbol exn_symbol)
+        (Flambda.create_let denominator (Expr arg2)
+          (Flambda.create_let numerator (Expr arg1)
+            (Flambda.create_let is_zero
+              (Prim (Pintcomp Ceq, [zero; denominator], Debuginfo.none))
+                (If_then_else (is_zero,
+                  name_expr (Prim (Praise Raise_regular, [exn],
+                      Debuginfo.none))
+                    ~name:"dummy",
+                  (* CR-someday pchambart: find the right event.
+                     mshinwell: I briefly looked at this, and couldn't
+                     figure it out.
+                     lwhite: I don't think any of the existing events
+                     are suitable. I had to add a new one for a similar
+                     case in the array data types work.
+                     mshinwell: deferred CR *)
+                  (* Debuginfo.from_raise event *)
+                  name_expr ~name:"result"
+                    (Prim (prim, [numerator; denominator],
+                      Debuginfo.none))))))))
+  | Lprim ((Pdivint | Pmodint), _) when not !Clflags.fast ->
+    Misc.fatal_error "Pdivint / Pmodint must have exactly two arguments"
+  | Lprim (Psequor, [arg1; arg2]) ->
+    let arg1 = close t env arg1 in
+    let arg2 = close t env arg2 in
+    let const_true = Variable.create "const_true" in
+    let cond = Variable.create "cond_sequor" in
+    Flambda.create_let const_true (Const (Int 1))
+      (Flambda.create_let cond (Expr arg1)
+        (If_then_else (cond, Var const_true, arg2)))
+  | Lprim (Psequand, [arg1; arg2]) ->
+    let arg1 = close t env arg1 in
+    let arg2 = close t env arg2 in
+    let const_false = Variable.create "const_false" in
+    let cond = Variable.create "cond_sequand" in
+    Flambda.create_let const_false (Const (Int 0))
+      (Flambda.create_let cond (Expr arg1)
+        (If_then_else (cond, arg2, Var const_false)))
+  | Lprim ((Psequand | Psequor), _) ->
+    Misc.fatal_error "Psequand / Psequor must have exactly two arguments"
+  | Lprim (Pidentity, [arg]) -> close t env arg
+  | Lprim (Pdirapply loc, [funct; arg])
+  | Lprim (Prevapply loc, [arg; funct]) ->
+    let apply : Lambda.lambda_apply =
+      { ap_func = funct;
+        ap_args = [arg];
+        ap_loc = loc;
+        ap_should_be_tailcall = false;
+        (* CR-someday lwhite: it would be nice to be able to give
+           inlined attributes to functions applied with the application
+           operators. *)
+        ap_inlined = Default_inline;
+      }
+    in
+    close t env (Lambda.Lapply apply)
+  | Lprim (Praise kind, [Levent (arg, event)]) ->
+    let arg_var = Variable.create "raise_arg" in
+    Flambda.create_let arg_var (Expr (close t env arg))
+      (name_expr
+        (Prim (Praise kind, [arg_var], Debuginfo.from_raise event))
+        ~name:"raise")
+  | Lprim (Pfield _, [Lprim (Pgetglobal id, [])])
+      when Ident.same id t.current_unit_id ->
+    Misc.fatal_errorf "[Pfield (Pgetglobal ...)] for the current compilation \
+        unit is forbidden upon entry to the middle end"
+  | Lprim (Psetfield (_, _, _), [Lprim (Pgetglobal _, []); _]) ->
+    Misc.fatal_errorf "[Psetfield (Pgetglobal ...)] is \
+        forbidden upon entry to the middle end"
+  | Lprim (Pgetglobal id, []) when Ident.is_predef_exn id ->
+    let symbol = t.symbol_for_global' id in
+    t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols;
+    name_expr (Symbol symbol) ~name:"predef_exn"
+  | Lprim (Pgetglobal id, []) ->
+    assert (not (Ident.same id t.current_unit_id));
+    let symbol = t.symbol_for_global' id in
+    t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols;
+    name_expr (Symbol symbol) ~name:"Pgetglobal"
+  | Lprim (p, args) ->
+    (* One of the important consequences of the ANF-like representation
+       here is that we obtain names corresponding to the components of
+       blocks being made (with [Pmakeblock]).  This information can be used
+       by the simplification pass to increase the likelihood of eliminating
+       the allocation, since some field accesses can be tracked back to known
+       field values. ,*)
+    let name = Printlambda.string_of_primitive p in
+    Lift_code.lifting_helper (close_list t env args)
+      ~evaluation_order:`Right_to_left
+      ~name:(name ^ "_arg")
+      ~create_body:(fun args ->
+        name_expr (Prim (p, args, Debuginfo.none)) ~name)
+  | Lswitch (arg, sw) ->
+    let scrutinee = Variable.create "switch" in
+    let aux (i, lam) = i, close t env lam in
+    let zero_to_n = Numbers.Int.zero_to_n in
+    Flambda.create_let scrutinee (Expr (close t env arg))
+      (Switch (scrutinee,
+        { numconsts = zero_to_n (sw.sw_numconsts - 1);
+          consts = List.map aux sw.sw_consts;
+          numblocks = zero_to_n (sw.sw_numblocks - 1);
+          blocks = List.map aux sw.sw_blocks;
+          failaction = Misc.may_map (close t env) sw.sw_failaction;
+        }))
+  | Lstringswitch (arg, sw, def) ->
+    let scrutinee = Variable.create "string_switch" in
+    Flambda.create_let scrutinee (Expr (close t env arg))
+      (String_switch (scrutinee,
+        List.map (fun (s, e) -> s, close t env e) sw,
+        Misc.may_map (close t env) def))
+  | Lstaticraise (i, args) ->
+    Lift_code.lifting_helper (close_list t env args)
+      ~evaluation_order:`Right_to_left
+      ~name:"staticraise_arg"
+      ~create_body:(fun args ->
+        let static_exn = Env.find_static_exception env i in
+        Static_raise (static_exn, args))
+  | Lstaticcatch (body, (i, ids), handler) ->
+    let st_exn = Static_exception.create () in
+    let env = Env.add_static_exception env i st_exn in
+    let vars = List.map (Variable.create_with_same_name_as_ident) ids in
+    Static_catch (st_exn, vars, close t env body,
+      close t (Env.add_vars env ids vars) handler)
+  | Ltrywith (body, id, handler) ->
+    let var = Variable.create_with_same_name_as_ident id in
+    Try_with (close t env body, var, close t (Env.add_var env id var) handler)
+  | Lifthenelse (cond, ifso, ifnot) ->
+    let cond = close t env cond in
+    let cond_var = Variable.create "cond" in
+    Flambda.create_let cond_var (Expr cond)
+      (If_then_else (cond_var, close t env ifso, close t env ifnot))
+  | Lsequence (lam1, lam2) ->
+    let var = Variable.create "sequence" in
+    let lam1 = Flambda.Expr (close t env lam1) in
+    let lam2 = close t env lam2 in
+    Flambda.create_let var lam1 lam2
+  | Lwhile (cond, body) -> While (close t env cond, close t env body)
+  | Lfor (id, lo, hi, direction, body) ->
+    let bound_var = Variable.create_with_same_name_as_ident id in
+    let from_value = Variable.create "for_from" in
+    let to_value = Variable.create "for_to" in
+    let body = close t (Env.add_var env id bound_var) body in
+    Flambda.create_let from_value (Expr (close t env lo))
+      (Flambda.create_let to_value (Expr (close t env hi))
+        (For { bound_var; from_value; to_value; direction; body; }))
+  | Lassign (id, new_value) ->
+    let being_assigned =
+      match Env.find_mutable_var_exn env id with
+      | being_assigned -> being_assigned
+      | exception Not_found ->
+        Misc.fatal_errorf "Closure_conversion.close: unbound mutable \
+            variable %s in assignment"
+          (Ident.unique_name id)
+    in
+    let new_value_var = Variable.create "new_value" in
+    Flambda.create_let new_value_var (Expr (close t env new_value))
+      (Assign { being_assigned; new_value = new_value_var; })
+  | Levent (lam, ev) -> add_debug_info ev (close t env lam)
+  | Lifused _ ->
+    (* [Lifused] is used to mark that this expression should be alive only if
+       an identifier is.  Every use should have been removed by
+       [Simplif.simplify_lets], either by replacing by the inner expression,
+       or by completely removing it (replacing by unit). *)
+    Misc.fatal_error "[Lifused] should have been removed by \
+        [Simplif.simplify_lets]"
+
+(** Perform closure conversion on a set of function declarations, returning a
+    set of closures.  (The set will often only contain a single function;
+    the only case where it cannot is for "let rec".) *)
+and close_functions t external_env function_declarations : Flambda.named =
+  let closure_env_without_parameters =
+    Function_decls.closure_env_without_parameters
+      external_env function_declarations
+  in
+  let all_free_idents = Function_decls.all_free_idents function_declarations in
+  let close_one_function map decl =
+    let body = Function_decl.body decl in
+    let dbg =
+      (* Move any debugging event that may exist at the start of the function
+         body onto the function declaration itself. *)
+      match body with
+      | Levent (_, ({ lev_kind = Lev_function } as ev)) ->
+        Debuginfo.from_call ev
+      | _ -> Debuginfo.none
+    in
+    let params = Function_decl.params decl in
+    (* Create fresh variables for the elements of the closure (cf.
+       the comment on [Function_decl.closure_env_without_parameters], above).
+       This induces a renaming on [Function_decl.free_idents]; the results of
+       that renaming are stored in [free_variables]. *)
+    let closure_env =
+      List.fold_right (fun id env ->
+          Env.add_var env id (Variable.create_with_same_name_as_ident id))
+        params closure_env_without_parameters
+    in
+    (* If the function is the wrapper for a function with an optional
+       argument with a default value, make sure it always gets inlined.
+       CR-someday pchambart: eta-expansion wrapper for a primitive are
+       not marked as stub but certainly should *)
+    let stub, body =
+      match Function_decl.primitive_wrapper decl with
+      | None -> false, body
+      | Some wrapper_body -> true, wrapper_body
+    in
+    let params = List.map (Env.find_var closure_env) params in
+    let closure_bound_var = Function_decl.closure_bound_var decl in
+    let body = close t closure_env body in
+    let fun_decl =
+      Flambda.create_function_declaration ~params ~body ~stub ~dbg
+        ~inline:(Function_decl.inline decl)
+        ~is_a_functor:(Function_decl.is_a_functor decl)
+    in
+    match Function_decl.kind decl with
+    | Curried -> Variable.Map.add closure_bound_var fun_decl map
+    | Tupled ->
+      let unboxed_version = Variable.rename closure_bound_var in
+      let generic_function_stub =
+        tupled_function_call_stub params unboxed_version
+      in
+      Variable.Map.add unboxed_version fun_decl
+        (Variable.Map.add closure_bound_var generic_function_stub map)
+  in
+  let function_decls =
+    Flambda.create_function_declarations
+      ~set_of_closures_id:
+        (Set_of_closures_id.create (Compilation_unit.get_current_exn ()))
+      ~funs:
+        (List.fold_left close_one_function Variable.Map.empty
+          (Function_decls.to_list function_declarations))
+  in
+  (* The closed representation of a set of functions is a "set of closures".
+     (For avoidance of doubt, the runtime representation of the *whole set* is
+     a single block with tag [Closure_tag].) *)
+  let set_of_closures =
+    let free_vars =
+      IdentSet.fold (fun var map ->
+          let internal_var =
+            Env.find_var closure_env_without_parameters var
+          in
+          let external_var = Env.find_var external_env var in
+          Variable.Map.add internal_var external_var map)
+        all_free_idents Variable.Map.empty
+    in
+    Flambda.create_set_of_closures ~function_decls ~free_vars
+      ~specialised_args:Variable.Map.empty
+  in
+  Set_of_closures set_of_closures
+
+and close_list t sb l = List.map (close t sb) l
+
+and close_let_bound_expression t ?let_rec_ident let_bound_var env
+      (lam : Lambda.lambda) : Flambda.named =
+  match lam with
+  | Lfunction { kind; params; body; attr; } ->
+    (* Ensure that [let] and [let rec]-bound functions have appropriate
+       names. *)
+    let closure_bound_var = Variable.rename let_bound_var in
+    let decl =
+      Function_decl.create ~let_rec_ident ~closure_bound_var ~kind ~params
+        ~body ~inline:attr.inline ~is_a_functor:attr.is_a_functor
+    in
+    let set_of_closures_var =
+      Variable.rename let_bound_var ~append:"_set_of_closures"
+    in
+    let set_of_closures =
+      close_functions t env (Function_decls.create [decl])
+    in
+    let project_closure : Flambda.project_closure =
+      { set_of_closures = set_of_closures_var;
+        closure_id = Closure_id.wrap closure_bound_var;
+      }
+    in
+    Expr (Flambda.create_let set_of_closures_var set_of_closures
+      (name_expr (Project_closure (project_closure))
+        ~name:(Variable.unique_name let_bound_var)))
+  | lam -> Expr (close t env lam)
+
+let lambda_to_flambda ~backend ~module_ident ~size lam : Flambda.program =
+  let module Backend = (val backend : Backend_intf.S) in
+  let compilation_unit = Compilation_unit.get_current_exn () in
+  let t =
+    { current_unit_id =
+        Compilation_unit.get_persistent_ident compilation_unit;
+      symbol_for_global' = Backend.symbol_for_global';
+      imported_symbols = Symbol.Set.empty;
+    }
+  in
+  let module_symbol = Backend.symbol_for_global' module_ident in
+  let block_symbol =
+    let linkage_name = Linkage_name.create "module_as_block" in
+    Symbol.create compilation_unit linkage_name
+  in
+  (* The global module block is built by accessing the fields of all the
+     introduced symbols. *)
+  (* CR-soon mshinwell for mshinwell: Add a comment describing how modules are
+     compiled. *)
+  let fields =
+    Array.init size (fun pos ->
+      let pos_str = string_of_int pos in
+      let sym_v = Variable.create ("block_symbol_" ^ pos_str) in
+      let result_v = Variable.create ("block_symbol_get_" ^ pos_str) in
+      let value_v = Variable.create ("block_symbol_get_field_" ^ pos_str) in
+      Flambda.create_let
+        sym_v (Symbol block_symbol)
+         (Flambda.create_let result_v
+            (Prim (Pfield 0, [sym_v], Debuginfo.none))
+            (Flambda.create_let value_v
+              (Prim (Pfield pos, [result_v], Debuginfo.none))
+              (Var value_v))))
+  in
+  let module_initializer : Flambda.program_body =
+    Initialize_symbol (
+      block_symbol,
+      Tag.create_exn 0,
+      [close t Env.empty lam],
+      Initialize_symbol (
+        module_symbol,
+        Tag.create_exn 0,
+        Array.to_list fields,
+        End module_symbol))
+  in
+  { imported_symbols = t.imported_symbols;
+    program_body = module_initializer;
+  }

middle_end/closure_conversion.mli

@@ -0,0 +1,50 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Generation of [Flambda] intermediate language code from [Lambda] code
+  by performing a form of closure conversion.
+
+  Function declarations (which may bind one or more variables identifying
+  functions, possibly with mutual recursion) are transformed to
+  [Set_of_closures] expressions.  [Project_closure] expressions are then
+  used to select a closure for a particular function from a [Set_of_closures]
+  expression.  The [Set_of_closures] expressions say nothing about the
+  actual runtime layout of the closures; this is handled when [Flambda] code
+  is translated to [Clambda] code.
+
+  The following transformations are also performed during closure
+  conversion:
+  - Constant blocks (by which is meant things wrapped in [Lambda.Const_block])
+    are converted to applications of the [Pmakeblock] primitive.
+  - [Levent] debugging event nodes are removed and the information within
+    them attached to function, method and [raise] calls.
+  - Tuplified functions are converted to curried functions and a stub
+    function emitted to call the curried version.  For example:
+      let rec f (x, y) = f (x + 1, y + 1)
+    is transformed to:
+      let rec internal_f x y = f (x + 1,y + 1)
+      and f (x, y) = internal_f x y  (* [f] is marked as a stub function *)
+  - The [Pdirapply] and [Prevapply] application primitives are removed and
+    converted to normal [Flambda] application nodes.
+
+  The [lambda_to_flambda] function is not re-entrant.
+*)
+val lambda_to_flambda
+   : backend:(module Backend_intf.S)
+  -> module_ident:Ident.t
+  -> size:int
+  -> Lambda.lambda
+  -> Flambda.program

middle_end/closure_conversion_aux.ml

@@ -0,0 +1,184 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+module IdentSet = Lambda.IdentSet
+
+module Env = struct
+  type t = {
+    variables : Variable.t Ident.tbl;
+    mutable_variables : Mutable_variable.t Ident.tbl;
+    static_exceptions : Static_exception.t Numbers.Int.Map.t;
+    globals : Symbol.t Numbers.Int.Map.t;
+    at_toplevel : bool;
+  }
+
+  let empty = {
+    variables = Ident.empty;
+    mutable_variables = Ident.empty;
+    static_exceptions = Numbers.Int.Map.empty;
+    globals = Numbers.Int.Map.empty;
+    at_toplevel = true;
+  }
+
+  let clear_local_bindings env =
+    { empty with globals = env.globals }
+
+  let add_var t id var = { t with variables = Ident.add id var t.variables }
+  let add_vars t ids vars = List.fold_left2 add_var t ids vars
+
+  let find_var t id =
+    try Ident.find_same id t.variables
+    with Not_found ->
+      Misc.fatal_errorf "Closure_conversion.Env.find_var: %s@ %s"
+        (Ident.unique_name id)
+        (Printexc.raw_backtrace_to_string (Printexc.get_callstack 42))
+
+  let find_var_exn t id =
+    Ident.find_same id t.variables
+
+  let add_mutable_var t id mutable_var =
+    { t with mutable_variables = Ident.add id mutable_var t.mutable_variables }
+
+  let find_mutable_var_exn t id =
+    Ident.find_same id t.mutable_variables
+
+  let add_static_exception t st_exn fresh_st_exn =
+    { t with
+      static_exceptions =
+        Numbers.Int.Map.add st_exn fresh_st_exn t.static_exceptions }
+
+  let find_static_exception t st_exn =
+    try Numbers.Int.Map.find st_exn t.static_exceptions
+    with Not_found ->
+      Misc.fatal_error ("Closure_conversion.Env.find_static_exception: exn "
+        ^ string_of_int st_exn)
+
+  let add_global t pos symbol =
+    { t with globals = Numbers.Int.Map.add pos symbol t.globals }
+
+  let find_global t pos =
+    try Numbers.Int.Map.find pos t.globals
+    with Not_found ->
+      Misc.fatal_error ("Closure_conversion.Env.find_global: global "
+        ^ string_of_int pos)
+
+  let at_toplevel t = t.at_toplevel
+
+  let not_at_toplevel t = { t with at_toplevel = false; }
+end
+
+module Function_decls = struct
+  module Function_decl = struct
+    type t = {
+      let_rec_ident : Ident.t;
+      closure_bound_var : Variable.t;
+      kind : Lambda.function_kind;
+      params : Ident.t list;
+      body : Lambda.lambda;
+      free_idents_of_body : IdentSet.t;
+      inline : Lambda.inline_attribute;
+      is_a_functor : bool;
+    }
+
+    let create ~let_rec_ident ~closure_bound_var ~kind ~params ~body ~inline
+        ~is_a_functor =
+      let let_rec_ident =
+        match let_rec_ident with
+        | None -> Ident.create "unnamed_function"
+        | Some let_rec_ident -> let_rec_ident
+      in
+      { let_rec_ident;
+        closure_bound_var;
+        kind;
+        params;
+        body;
+        free_idents_of_body = Lambda.free_variables body;
+        inline;
+        is_a_functor;
+      }
+
+    let let_rec_ident t = t.let_rec_ident
+    let closure_bound_var t = t.closure_bound_var
+    let kind t = t.kind
+    let params t = t.params
+    let body t = t.body
+    let free_idents t = t.free_idents_of_body
+    let inline t = t.inline
+    let is_a_functor t = t.is_a_functor
+
+    (* CR-someday mshinwell: eliminate "*stub*" *)
+    let primitive_wrapper t =
+      match t.body with
+      | Lprim (Pccall { Primitive.prim_name = "*stub*" }, [body]) -> Some body
+      | _ -> None
+  end
+
+  type t = {
+    function_decls : Function_decl.t list;
+    all_free_idents : IdentSet.t;
+  }
+
+  (* All identifiers free in the bodies of the given function declarations,
+     indexed by the identifiers corresponding to the functions themselves. *)
+  let free_idents_by_function function_decls =
+    List.fold_right (fun decl map ->
+        Variable.Map.add (Function_decl.closure_bound_var decl)
+          (Function_decl.free_idents decl) map)
+      function_decls Variable.Map.empty
+
+  let all_free_idents function_decls =
+    Variable.Map.fold (fun _ -> IdentSet.union)
+      (free_idents_by_function function_decls) IdentSet.empty
+
+  (* All identifiers of simultaneously-defined functions in [ts]. *)
+  let let_rec_idents function_decls =
+    List.map Function_decl.let_rec_ident function_decls
+
+  (* All parameters of functions in [ts]. *)
+  let all_params function_decls =
+    List.concat (List.map Function_decl.params function_decls)
+
+  let set_diff (from : IdentSet.t) (idents : Ident.t list) =
+    List.fold_right IdentSet.remove idents from
+
+  (* CR lwhite: use a different name from above or explain the difference *)
+  let all_free_idents function_decls =
+    set_diff (set_diff (all_free_idents function_decls)
+        (all_params function_decls))
+      (let_rec_idents function_decls)
+
+  let create function_decls =
+    { function_decls;
+      all_free_idents = all_free_idents function_decls;
+    }
+
+  let to_list t = t.function_decls
+
+  let all_free_idents t = t.all_free_idents
+
+  let closure_env_without_parameters external_env t =
+    let closure_env =
+      (* For "let rec"-bound functions. *)
+      List.fold_right (fun function_decl env ->
+          Env.add_var env (Function_decl.let_rec_ident function_decl)
+            (Function_decl.closure_bound_var function_decl))
+        t.function_decls (Env.clear_local_bindings external_env)
+    in
+    (* For free variables. *)
+    IdentSet.fold (fun id env ->
+        Env.add_var env id (Variable.create (Ident.name id)))
+      t.all_free_idents closure_env
+end

middle_end/closure_conversion_aux.mli

@@ -0,0 +1,94 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Environments and auxiliary structures used during closure conversion. *)
+
+(** Used to remember which [Variable.t] values correspond to which
+    [Ident.t] values during closure conversion, and similarly for
+     static exception identifiers. *)
+module Env : sig
+  type t
+
+  val empty : t
+
+  val add_var : t -> Ident.t -> Variable.t -> t
+  val add_vars : t -> Ident.t list -> Variable.t list -> t
+
+  val find_var : t -> Ident.t -> Variable.t
+  val find_var_exn : t -> Ident.t -> Variable.t
+
+  val add_mutable_var : t -> Ident.t -> Mutable_variable.t -> t
+  val find_mutable_var_exn : t -> Ident.t -> Mutable_variable.t
+
+  val add_static_exception : t -> int -> Static_exception.t -> t
+  val find_static_exception : t -> int -> Static_exception.t
+
+  val add_global : t -> int -> Symbol.t -> t
+  val find_global : t -> int -> Symbol.t
+
+  val at_toplevel : t -> bool
+  val not_at_toplevel : t -> t
+end
+
+(** Used to represent information about a set of function declarations
+    during closure conversion.  (The only case in which such a set may
+    contain more than one declaration is when processing "let rec".) *)
+module Function_decls : sig
+  module Function_decl : sig
+    type t
+
+    val create
+       : let_rec_ident:Ident.t option
+      -> closure_bound_var:Variable.t
+      -> kind:Lambda.function_kind
+      -> params:Ident.t list
+      -> body:Lambda.lambda
+      -> inline:Lambda.inline_attribute
+      -> is_a_functor:bool
+      -> t
+
+    val let_rec_ident : t -> Ident.t
+    val closure_bound_var : t -> Variable.t
+    val kind : t -> Lambda.function_kind
+    val params : t -> Ident.t list
+    val body : t -> Lambda.lambda
+    val inline : t -> Lambda.inline_attribute
+    val is_a_functor : t -> bool
+
+    (* [primitive_wrapper t] is [None] iff [t] is not a wrapper for a function
+       with default optionnal arguments. Otherwise it is [Some body], where
+       [body] is the body of the wrapper. *)
+    val primitive_wrapper : t -> Lambda.lambda option
+
+    (* Like [all_free_idents], but for just one function. *)
+    val free_idents : t -> Lambda.IdentSet.t
+  end
+
+  type t
+
+  val create : Function_decl.t list -> t
+  val to_list : t -> Function_decl.t list
+
+  (* All identifiers free in the given function declarations after the binding
+     of parameters and function identifiers has been performed. *)
+  val all_free_idents : t -> Lambda.IdentSet.t
+
+  (* A map from identifiers to their corresponding [Variable.t]s whose domain
+     is the set of all identifiers free in the bodies of the declarations that
+     are not bound as parameters.
+     It also contains the globals bindings of the provided environment. *)
+  val closure_env_without_parameters : Env.t -> t -> Env.t
+end

middle_end/effect_analysis.ml

@@ -0,0 +1,55 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+let no_effects_prim (prim : Lambda.primitive) =
+  match Semantics_of_primitives.for_primitive prim with
+  | (No_effects | Only_generative_effects), (No_coeffects | Has_coeffects) ->
+    true
+  | _ -> false
+
+let rec no_effects (flam : Flambda.t) =
+  match flam with
+  | Var _ -> true
+  | Let { defining_expr; body; _ } ->
+    no_effects_named defining_expr && no_effects body
+  | Let_mutable (_, _, body) -> no_effects body
+  | Let_rec (defs, body) ->
+    no_effects body
+      && List.for_all (fun (_, def) -> no_effects_named def) defs
+  | If_then_else (_, ifso, ifnot) -> no_effects ifso && no_effects ifnot
+  | Switch (_, sw) ->
+    let aux (_, flam) = no_effects flam in
+    List.for_all aux sw.blocks
+      && List.for_all aux sw.consts
+      && Misc.may_default no_effects sw.failaction true
+  | String_switch (_, sw, def) ->
+    List.for_all (fun (_, lam) -> no_effects lam) sw
+      && Misc.may_default no_effects def true
+  | Static_catch (_, _, body, _) | Try_with (body, _, _) ->
+    (* If there is a [raise] in [body], the whole [Try_with] may have an
+       effect, so there is no need to test the handler. *)
+    no_effects body
+  | While _ | For _ | Apply _ | Send _ | Assign _ | Static_raise _ -> false
+  | Proved_unreachable -> true
+
+and no_effects_named (named : Flambda.named) =
+  match named with
+  | Symbol _ | Const _ | Allocated_const _ | Read_mutable _
+  | Read_symbol_field _
+  | Set_of_closures _ | Project_closure _ | Project_var _
+  | Move_within_set_of_closures _ -> true
+  | Prim (prim, _, _) -> no_effects_prim prim
+  | Expr flam -> no_effects flam

middle_end/effect_analysis.mli

@@ -0,0 +1,25 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Simple side effect analysis. *)
+
+(* CR-someday pchambart: Replace by call to [Purity] module.
+   mshinwell: Where is the [Purity] module? *)
+(** Conservative approximation as to whether a given Flambda expression may
+    have any side effects. *)
+val no_effects : Flambda.t -> bool
+
+val no_effects_named : Flambda.named -> bool

middle_end/find_recursive_functions.ml

@@ -0,0 +1,29 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+let in_function_declarations (function_decls : Flambda.function_declarations)
+      ~backend =
+  let module VCC = Sort_connected_components.Make (Variable) in
+  let directed_graph =
+    Flambda_utils.fun_vars_referenced_in_decls function_decls ~backend
+  in
+  let connected_components =
+    VCC.connected_components_sorted_from_roots_to_leaf directed_graph
+  in
+  Array.fold_left (fun rec_fun -> function
+      | VCC.No_loop _ -> rec_fun
+      | VCC.Has_loop elts -> List.fold_right Variable.Set.add elts rec_fun)
+    Variable.Set.empty connected_components

middle_end/find_recursive_functions.mli

@@ -0,0 +1,35 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** "Recursive functions" are those functions [f] that might call either:
+    - themselves, or
+    - another function that in turn might call [f].
+
+    For example in the following simultaneous definition of [f] [g] and [h],
+    [f] and [g] are recursive functions, but not [h]:
+      [let rec f x = g x
+       and g x = f x
+       and h x = g x]
+*)
+
+(** Determine the recursive functions, if any, bound by the given set of
+    function declarations.
+    This is only intended to be used by [Flambda.create_function_declarations].
+*)
+val in_function_declarations
+   : Flambda.function_declarations
+  -> backend:(module Backend_intf.S)
+  -> Variable.Set.t

middle_end/flambda.mli

@@ -0,0 +1,599 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Intermediate language used for tree-based analysis and optimization. *)
+
+(** Whether the callee in a function application is known at compile time. *)
+type call_kind =
+  | Indirect
+  | Direct of Closure_id.t
+
+(** Simple constants.  ("Structured constants" are rewritten to invocations
+    of [Pmakeblock] so that they easily take part in optimizations.) *)
+type const =
+  | Int of int
+  | Char of char
+  (** [Char] is kept separate from [Int] to improve printing *)
+  | Const_pointer of int
+  (** [Const_pointer] is an immediate value of a type whose values may be
+     boxed (typically a variant type with both constant and non-constant
+     constructors). *)
+
+(** The application of a function to a list of arguments. *)
+type apply = {
+  (* CR-soon mshinwell: rename func -> callee, and
+     lhs_of_application -> callee *)
+  func : Variable.t;
+  args : Variable.t list;
+  kind : call_kind;
+  dbg : Debuginfo.t;
+  inline : Lambda.inline_attribute;
+  (** Instructions from the source code as to whether the callee should
+      be inlined. *)
+}
+
+(** The update of a mutable variable.  Mutable variables are distinct from
+    immutable variables in Flambda. *)
+type assign = {
+  being_assigned : Mutable_variable.t;
+  new_value : Variable.t;
+}
+
+(** The invocation of a method. *)
+type send = {
+  kind : Lambda.meth_kind;
+  meth : Variable.t;
+  obj : Variable.t;
+  args : Variable.t list;
+  dbg : Debuginfo.t;
+}
+
+(** The selection of one closure given a set of closures, required before
+    a function defined by said set of closures can be applied.  See more
+    detailed documentation below on [set_of_closures]. *)
+type project_closure = {
+  set_of_closures : Variable.t; (** must yield a set of closures *)
+  closure_id : Closure_id.t;
+}
+
+(** The selection of one closure given another closure in the same set of
+    closures.  See more detailed documentation below on [set_of_closures]. *)
+type move_within_set_of_closures = {
+  closure : Variable.t;  (** must yield a closure *)
+  start_from : Closure_id.t;
+  move_to : Closure_id.t;
+}
+
+(** The selection from a closure of a variable bound by said closure.
+    In other words, access to a function's environment.  Also see more
+    detailed documentation below on [set_of_closures]. *)
+type project_var = {
+  closure : Variable.t;  (** must yield a closure *)
+  closure_id : Closure_id.t;
+  var : Var_within_closure.t;
+}
+
+(** Flambda terms are partitioned in a pseudo-ANF manner; many terms are
+    required to be [let]-bound.  This in particular ensures there is always
+    a variable name for an expression that may be lifted out (for example
+    if it is found to be constant).
+    Note: All bound variables in Flambda terms must be distinct.
+    [Flambda_invariants] verifies this. *)
+type t =
+  | Var of Variable.t
+  | Let of let_expr
+  | Let_mutable of Mutable_variable.t * Variable.t * t
+  | Let_rec of (Variable.t * named) list * t
+  (** CR-someday lwhite: give Let_rec the same fields as Let. *)
+  | Apply of apply
+  | Send of send
+  | Assign of assign
+  | If_then_else of Variable.t * t * t
+  | Switch of Variable.t * switch
+  | String_switch of Variable.t * (string * t) list * t option
+  (** Restrictions on [Lambda.Lstringswitch] also apply to [String_switch]. *)
+  | Static_raise of Static_exception.t * Variable.t list
+  | Static_catch of Static_exception.t * Variable.t list * t * t
+  | Try_with of t * Variable.t * t
+  | While of t * t
+  | For of for_loop
+  | Proved_unreachable
+
+(** Values of type [named] will always be [let]-bound to a [Variable.t]. *)
+and named =
+  | Symbol of Symbol.t
+  | Const of const
+  | Allocated_const of Allocated_const.t
+  | Read_mutable of Mutable_variable.t
+  | Read_symbol_field of Symbol.t * int
+  (** During the lifting of [let] bindings to [program] constructions after
+      closure conversion, we generate symbols and their corresponding
+      definitions (which may or may not be constant), together with field
+      accesses to such symbols.  We would like it to be the case that such
+      field accesses are simplified to the relevant component of the
+      symbol concerned.  (The rationale is to generate efficient code and
+      share constants as expected: see e.g. tests/asmcomp/staticalloc.ml.)
+      The components of the symbol would be identified by other symbols.
+      This sort of access pattern is feasible because the top-level structure
+      of symbols is statically allocated and fixed at compile time.
+      It may seem that [Prim (Pfield, ...)] expressions could be used to
+      perform the field accesses.  However for simplicity, to avoid having to
+      keep track of properties of individual fields of blocks,
+      [Inconstant_idents] never deems a [Prim (Pfield, ...)] expression to be
+      constant.  This would in general prevent field accesses to symbols from
+      being simplified in the way we would like, since [Lift_constants] would
+      not assign new symbols (i.e. the things we would like to simplify to)
+      to the various projections from the symbols in question.
+      To circumvent this problem we use [Read_symbol_field] when generating
+      projections from the top level of symbols.  Owing to the properties of
+      symbols described above, such expressions may be eligible for declaration
+      as constant by [Inconstant_idents] (and thus themselves lifted to another
+      symbol), without any further complication.
+      [Read_symbol_field] may only be used when the definition of the symbol
+      is in scope in the [program].  For external unresolved symbols, [Pfield]
+      may still be used; it will be changed to [Read_symbol_field] by
+      [Inline_and_simplify] when (and if) the symbol is imported. *)
+  | Set_of_closures of set_of_closures
+  | Project_closure of project_closure
+  | Move_within_set_of_closures of move_within_set_of_closures
+  | Project_var of project_var
+  | Prim of Lambda.primitive * Variable.t list * Debuginfo.t
+  | Expr of t  (** ANF escape hatch. *)
+
+(* CR-someday mshinwell: use [letcont]-style construct to remove e.g.
+   [While] and [For]. *)
+(* CR-someday mshinwell: try to produce a tighter definition of a "switch"
+   (and translate to that earlier) so that middle- and back-end code for
+   these can be reduced. *)
+(* CR-someday mshinwell: remove [Expr], but to do this easily would probably
+   require a continuation-binding construct. *)
+(* CR-someday mshinwell: Since we lack expression identifiers on every term,
+   we should probably introduce [Mutable_var] into [named] if we introduce
+   more complicated analyses on these in the future.  Alternatively, maybe
+   consider removing mutable variables altogether. *)
+
+and let_expr = private {
+  var : Variable.t;
+  defining_expr : named;
+  body : t;
+  (* CR-someday mshinwell: we could consider having these be keys into some
+     kind of global cache, to reduce memory usage. *)
+  free_vars_of_defining_expr : Variable.Set.t;
+  (** A cache of the free variables in the defining expression of the [let]. *)
+  free_vars_of_body : Variable.Set.t;
+  (** A cache of the free variables of the body of the [let].  This is an
+      important optimization. *)
+}
+
+(** The representation of a set of function declarations (possibly mutually
+    recursive).  Such a set encapsulates the declarations themselves,
+    information about their defining environment, and information used
+    specifically for optimization.
+    Before a function can be applied it must be "projected" from a set of
+    closures to yield a "closure".  This is done using [Project_closure]
+    (see above).  Given a closure, not only can it be applied, but information
+    about its defining environment can be retrieved (using [Project_var],
+    see above).
+    At runtime, a [set_of_closures] corresponds to an OCaml value with tag
+    [Closure_tag] (possibly with inline [Infix_tag](s)).  As an optimization,
+    an operation ([Move_within_set_of_closures]) is provided (see above)
+    which enables one closure within a set to be located given another
+    closure in the same set.  This avoids keeping a pointer to the whole set
+    of closures alive when compiling, for example, mutually-recursive
+    functions.
+*)
+and set_of_closures = private {
+  function_decls : function_declarations;
+  (* CR-soon mshinwell: consider renaming [free_vars].  Also, it's still really
+     confusing which side of this map to use when.  "Vars bound by the
+     closure" is the domain.
+     Another example of when this is confusing:
+      let bound_vars_approx =
+        Variable.Map.map (Env.find_approx env) set.free_vars
+      in
+     in [Build_export_info]. *)
+  free_vars : Variable.t Variable.Map.t;
+  (** Mapping from all variables free in the body of the [function_decls] to
+      variables in scope at the definition point of the [set_of_closures].
+      The domain of this map is sometimes known as the "variables bound by
+      the closure". *)
+  specialised_args : Variable.t Variable.Map.t;
+  (** Parameters known to always alias some variable in the scope of the set
+      of closures declaration.  These are the only parameters that may,
+      during [Inline_and_simplify], have non-unknown approximations.
+
+      For instance, supposing all call sites of f are represented in this
+      example,
+        [let x = ... in
+         let f a b c = ... in
+         let y = ... in
+         f x y 1;
+         f x y 1]
+      the specialised arguments of f can (but does not necessarily) contain
+      the association [a] -> [x], but cannot contain [b] -> [y] because [f]
+      is not in the scope of [y]. If f were the recursive function
+      [let rec f a b c = f a 1 2 in], [a] -> [x] would still be a valid
+      specialised argument because all recursive calls maintain the invariant.
+
+      This information is used for optimisation purposes, if such a binding is
+      known, it is possible to specialise the body of the function according
+      to its parameter. This is usually introduced when specialising a
+      recursive function, for instance.
+        [let rec map f = function
+           | [] -> []
+           | h :: t -> f h :: map f t
+         let map_succ l =
+           let succ x = x + 1 in
+           map succ l]
+      [map] can be duplicated in [map_succ] to be specialised for the argument
+      [f]. This will result in
+        [let map_succ l =
+           let succ x = x + 1 in
+           let rec map f = function
+             | [] -> []
+             | h :: t -> f h :: map f t in
+           map succ l]
+      with map having [f] -> [succ] in its [specialised_args] field.
+
+      Note that it is usually not correct to erase this information if the
+      argument is used.
+  *)
+  (* CR mshinwell for pchambart: expand upon the last sentence of the previous
+     comment *)
+}
+
+and function_declarations = private {
+  set_of_closures_id : Set_of_closures_id.t;
+  (** An identifier (unique across all Flambda trees currently in memory)
+      of the set of closures associated with this set of function
+      declarations. *)
+  funs : function_declaration Variable.Map.t;
+  (** The function(s) defined by the set of function declarations.  The
+      keys of this map are often referred to in the code as "fun_var"s. *)
+}
+
+and function_declaration = private {
+  params : Variable.t list;
+  body : t;
+  (* CR-soon mshinwell: inconsistent naming free_variables/free_vars here and
+     above *)
+  free_variables : Variable.Set.t;
+  (** All variables free in the *body* of the function.  For example, a
+      variable that is bound as one of the function's parameters will still
+      be included in this set.  This field is present as an optimization. *)
+  free_symbols : Symbol.Set.t;
+  (** All symbols that occur in the function's body.  (Symbols can never be
+      bound in a function's body; the only thing that binds symbols is the
+      [program] constructions below.) *)
+  stub : bool;
+  (** A stub function is a generated function used to prepare arguments or
+      return values to allow indirect calls to functions with a special calling
+      convention.  For instance indirect calls to tuplified functions must go
+      through a stub.  Stubs will be unconditionally inlined. *)
+  dbg : Debuginfo.t;
+  (** Debug info for the function declaration. *)
+  inline : Lambda.inline_attribute;
+  (** Inlining requirements from the source code. *)
+  is_a_functor : bool;
+  (** Whether the function is known definitively to be a functor. *)
+}
+
+(** Equivalent to the similar type in [Lambda]. *)
+and switch = {
+  numconsts : Numbers.Int.Set.t; (** Integer cases *)
+  consts : (int * t) list; (** Integer cases *)
+  numblocks : Numbers.Int.Set.t; (** Number of tag block cases *)
+  blocks : (int * t) list; (** Tag block cases *)
+  failaction : t option; (** Action to take if none matched *)
+}
+
+(** Equivalent to the similar type in [Lambda]. *)
+and for_loop = {
+  bound_var : Variable.t;
+  from_value : Variable.t;
+  to_value : Variable.t;
+  direction : Asttypes.direction_flag;
+  body : t
+}
+
+(** Like a subset of [Flambda.named], except that instead of [Variable.t]s we
+    have [Symbol.t]s, and everything is a constant (i.e. with a fixed value
+    known at compile time).  Values of this type describe constants that will
+    be directly assigned to symbols in the object file (see below). *)
+and constant_defining_value =
+  | Allocated_const of Allocated_const.t
+    (** A single constant.  These are never "simple constants" (type [const])
+        but instead more complicated constructions. *)
+  | Block of Tag.t * constant_defining_value_block_field list
+    (** A pre-allocated block full of constants (either simple constants
+        or references to other constants, see below). *)
+  | Set_of_closures of set_of_closures
+    (** A closed (and thus constant) set of closures.  (That is to say,
+        [free_vars] must be empty.) *)
+  | Project_closure of Symbol.t * Closure_id.t
+    (** Selection of one closure from a constant set of closures.
+        Analogous to the equivalent operation on expressions. *)
+
+and constant_defining_value_block_field =
+  | Symbol of Symbol.t
+  | Const of const
+
+module Constant_defining_value :
+  Identifiable.S with type t = constant_defining_value
+
+type expr = t
+
+(** A "program" is the contents of one compilation unit.  It describes the
+    various values that are assigned to symbols (and in some cases fields of
+    such symbols) in the object file.  As such, it is closely related to
+    the compilation of toplevel modules. *)
+type program_body =
+  | Let_symbol of Symbol.t * constant_defining_value * program_body
+  (** Define the given symbol to have the given constant value. *)
+  | Let_rec_symbol of (Symbol.t * constant_defining_value) list * program_body
+  (** As for [Let_symbol], but recursive.  This is needed to treat examples
+      like this, where a constant set of closures is lifted to toplevel:
+
+        let rec f x = f x
+
+      After lifting this produces (in pseudo-Flambda):
+
+        Let_rec_symbol set_of_closures_symbol =
+          (Set_of_closures { f x ->
+            let applied_function = Symbol f_closure in
+            Apply (applied_function, x) })
+        and f_closure = Project_closure (set_of_closures_symbol, f)
+
+      Use of [Let_rec_symbol], by virtue of the special handling in
+      [Inline_and_simplify.define_let_rec_symbol_approx], enables the
+      approximation of the set of closures to be present in order to
+      correctly simplify the [Project_closure] construction.  (See
+      [Inline_and_simplify.simplify_project_closure] for that part.) *)
+  | Initialize_symbol of Symbol.t * Tag.t * t list * program_body
+  (** Define the given symbol as a constant block of the given size and
+      tag; but with a possibly non-constant initializer.  The initializer
+      will be executed at most once (from the entry point of the compilation
+      unit). *)
+  | Effect of t * program_body
+  (** Cause the given expression, which may have a side effect, to be
+      executed.  The resulting value is discarded.  [Effect] constructions
+      are never re-ordered. *)
+  | End of Symbol.t
+  (** [End] accepts the root symbol: the only symbol that can never be
+      eliminated. *)
+
+type program = {
+  imported_symbols : Symbol.Set.t;
+  program_body : program_body;
+}
+
+(** Compute the free variables of a term.  (This is O(1) for [Let]s).
+    If [ignore_uses_as_callee], all free variables inside [Apply] expressions
+    are ignored.  Likewise [ignore_uses_in_project_var] for [Project_var]
+    expressions.
+*)
+val free_variables
+   : ?ignore_uses_as_callee:unit
+  -> ?ignore_uses_in_project_var:unit
+  -> t
+  -> Variable.Set.t
+
+(** Compute the free variables of a named expression. *)
+val free_variables_named
+   : ?ignore_uses_in_project_var:unit
+  -> named
+  -> Variable.Set.t
+
+(** Compute _all_ variables occuring inside an expression.  (This is O(1)
+    for [Let]s). *)
+val used_variables
+   : ?ignore_uses_as_callee:unit
+  -> ?ignore_uses_in_project_var:unit
+  -> t
+  -> Variable.Set.t
+
+(** Compute _all_ variables occurring inside a named expression. *)
+val used_variables_named
+   : ?ignore_uses_in_project_var:unit
+  -> named
+  -> Variable.Set.t
+
+val free_symbols : expr -> Symbol.Set.t
+
+val free_symbols_named : named -> Symbol.Set.t
+
+val free_symbols_program : program -> Symbol.Set.t
+
+(** Used to avoid exceeding the stack limit when handling expressions with
+    multiple consecutive nested [Let]-expressions.  This saves rewriting large
+    simplification functions in CPS.  This function provides for the
+    rewriting or elimination of expressions during the fold. *)
+val fold_lets_option
+   : t
+  -> init:'a
+  -> for_defining_expr:('a -> Variable.t -> named -> 'a * Variable.t * named)
+  -> for_last_body:('a -> t -> t * 'b)
+  (* CR-someday mshinwell: consider making [filter_defining_expr]
+     optional *)
+  -> filter_defining_expr:('b -> Variable.t -> named -> Variable.Set.t ->
+                           'b * Variable.t * named option)
+  -> t * 'b
+
+(** Like [fold_lets_option], but just a map. *)
+val map_lets
+   : t
+  -> for_defining_expr:(Variable.t -> named -> named)
+  -> for_last_body:(t -> t)
+  -> after_rebuild:(t -> t)
+  -> t
+
+(** Like [map_lets], but just an iterator. *)
+val iter_lets
+   : t
+  -> for_defining_expr:(Variable.t -> named -> unit)
+  -> for_last_body:(t -> unit)
+  -> for_each_let:(t -> unit)
+  -> unit
+
+(** Creates a [Let] expression.  (This computes the free variables of the
+    defining expression and the body.) *)
+val create_let : Variable.t -> named -> t -> t
+
+(** Apply the specified function [f] to the defining expression of the given
+    [Let]-expression, returning a new [Let]. *)
+val map_defining_expr_of_let : let_expr -> f:(named -> named) -> t
+
+(** A module for the manipulation of terms where the recomputation of free
+    variable sets is to be kept to a minimum. *)
+module With_free_variables : sig
+  type 'a t
+
+  (** O(1) time. *)
+  val of_defining_expr_of_let : let_expr -> named t
+
+  (** O(1) time. *)
+  val of_body_of_let : let_expr -> expr t
+
+  (** Takes the time required to calculate the free variables of the given
+      term (proportional to the size of the term, except that the calculation
+      for [Let] is O(1)). *)
+  val of_expr : expr -> expr t
+
+  val of_named : named -> named t
+
+  (** Takes the time required to calculate the free variables of the given
+      [expr]. *)
+  val create_let_reusing_defining_expr
+     : Variable.t
+    -> named t
+    -> expr
+    -> expr
+
+  (** Takes the time required to calculate the free variables of the given
+      [named]. *)
+  val create_let_reusing_body
+     : Variable.t
+    -> named
+    -> expr t
+    -> expr
+
+  (** O(1) time. *)
+  val create_let_reusing_both
+     : Variable.t
+    -> named t
+    -> expr t
+    -> expr
+
+  (** The equivalent of the [Expr] constructor. *)
+  val expr : expr t -> named t
+
+  val contents : 'a t -> 'a
+
+  (** O(1) time. *)
+  val free_variables : _ t -> Variable.Set.t
+end
+
+(** Create a function declaration.  This calculates the free variables and
+    symbols occurring in the specified [body]. *)
+val create_function_declaration
+   : params:Variable.t list
+  -> body:t
+  -> stub:bool
+  -> dbg:Debuginfo.t
+  -> inline:Lambda.inline_attribute
+  -> is_a_functor:bool
+  -> function_declaration
+
+(** Create a set of function declarations given the individual declarations. *)
+val create_function_declarations
+   : set_of_closures_id:Set_of_closures_id.t
+  -> funs:function_declaration Variable.Map.t
+  -> function_declarations
+
+(** Convenience function to replace the [funs] member of a set of
+    function declarations. *)
+val update_function_declarations
+   : function_declarations
+  -> funs:function_declaration Variable.Map.t
+  -> function_declarations
+
+(** Create a set of closures.  Checks are made to ensure that [free_vars]
+    and [specialised_args] are reasonable. *)
+val create_set_of_closures
+   : function_decls:function_declarations
+  -> free_vars:Variable.t Variable.Map.t
+  -> specialised_args:Variable.t Variable.Map.t
+  -> set_of_closures
+
+(** Given a function declaration, find which of its parameters (if any)
+    are used in the body. *)
+val used_params : function_declaration -> Variable.Set.t
+
+type maybe_named =
+  | Is_expr of t
+  | Is_named of named
+
+(** This function is designed for the internal use of [Flambda_iterators].
+    See that module for iterators to be used over Flambda terms. *)
+val iter_general
+   : toplevel:bool
+  -> (t -> unit)
+  -> (named -> unit)
+  -> maybe_named
+  -> unit
+
+val print : Format.formatter -> t -> unit
+
+val print_named : Format.formatter -> named -> unit
+
+val print_program : Format.formatter -> program -> unit
+
+val print_const : Format.formatter -> const -> unit
+
+val print_constant_defining_value
+   : Format.formatter
+  -> constant_defining_value
+  -> unit
+
+val print_function_declaration
+   : Format.formatter
+  -> Variable.t * function_declaration
+  -> unit
+
+val print_function_declarations
+   : Format.formatter
+  -> function_declarations
+  -> unit
+
+val print_project_closure
+   : Format.formatter
+  -> project_closure
+  -> unit
+
+val print_move_within_set_of_closures
+   : Format.formatter
+  -> move_within_set_of_closures
+  -> unit
+
+val print_project_var
+   : Format.formatter
+  -> project_var
+  -> unit
+
+val print_set_of_closures
+   : Format.formatter
+  -> set_of_closures
+  -> unit

middle_end/flambda_invariants.ml

@@ -0,0 +1,731 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type flambda_kind =
+  | Normal
+  | Lifted
+
+(* Explicit "ignore" functions.  We name every pattern variable, avoiding
+   underscores, to try to avoid accidentally failing to handle (for example)
+   a particular variable.
+   We also avoid explicit record field access during the checking functions,
+   preferring instead to use exhaustive record matches.
+*)
+(* CR-someday pchambart: for sum types, we should probably add an exhaustive
+   pattern in ignores functions to be reminded if a type change *)
+let already_added_bound_variable_to_env (_ : Variable.t) = ()
+let will_traverse_named_expression_later (_ : Flambda.named) = ()
+let ignore_variable (_ : Variable.t) = ()
+let ignore_call_kind (_ : Flambda.call_kind) = ()
+let ignore_debuginfo (_ : Debuginfo.t) = ()
+let ignore_meth_kind (_ : Lambda.meth_kind) = ()
+let ignore_int (_ : int) = ()
+let ignore_int_set (_ : Numbers.Int.Set.t) = ()
+let ignore_bool (_ : bool) = ()
+let ignore_string (_ : string) = ()
+let ignore_static_exception (_ : Static_exception.t) = ()
+let ignore_direction_flag (_ : Asttypes.direction_flag) = ()
+let ignore_primitive ( _ : Lambda.primitive) = ()
+let ignore_const (_ : Flambda.const) = ()
+let ignore_allocated_const (_ : Allocated_const.t) = ()
+let ignore_set_of_closures_id (_ : Set_of_closures_id.t) = ()
+let ignore_closure_id (_ : Closure_id.t) = ()
+let ignore_var_within_closure (_ : Var_within_closure.t) = ()
+let ignore_tag (_ : Tag.t) = ()
+let ignore_inline_attribute (_ : Lambda.inline_attribute) = ()
+
+exception Binding_occurrence_not_from_current_compilation_unit of Variable.t
+exception Mutable_binding_occurrence_not_from_current_compilation_unit of
+  Mutable_variable.t
+exception Binding_occurrence_of_variable_already_bound of Variable.t
+exception Binding_occurrence_of_mutable_variable_already_bound of
+  Mutable_variable.t
+exception Binding_occurrence_of_symbol_already_bound of Symbol.t
+exception Unbound_variable of Variable.t
+exception Unbound_mutable_variable of Mutable_variable.t
+exception Unbound_symbol of Symbol.t
+exception Vars_in_function_body_not_bound_by_closure_or_params of
+  Variable.Set.t * Flambda.set_of_closures * Variable.t
+exception Function_decls_have_overlapping_parameters of Variable.Set.t
+exception Specialised_arg_that_is_not_a_parameter of Variable.t
+exception Free_variables_set_is_lying of
+  Variable.t * Variable.Set.t * Variable.Set.t * Flambda.function_declaration
+exception Set_of_closures_free_vars_map_has_wrong_range of Variable.Set.t
+exception Static_exception_not_caught of Static_exception.t
+exception Static_exception_caught_in_multiple_places of Static_exception.t
+exception Access_to_global_module_identifier of Lambda.primitive
+exception Pidentity_should_not_occur
+exception Pdirapply_should_be_expanded
+exception Prevapply_should_be_expanded
+exception Sequential_logical_operator_primitives_must_be_expanded of
+  Lambda.primitive
+exception Var_within_closure_bound_multiple_times of Var_within_closure.t
+exception Declared_closure_from_another_unit of Compilation_unit.t
+exception Closure_id_is_bound_multiple_times of Closure_id.t
+exception Set_of_closures_id_is_bound_multiple_times of Set_of_closures_id.t
+exception Unbound_closure_ids of Closure_id.Set.t
+exception Unbound_vars_within_closures of Var_within_closure.Set.t
+
+exception Flambda_invariants_failed
+
+(* CR-someday mshinwell: We should make "direct applications should not have
+   overapplication" be an invariant throughout.  At the moment I think this is
+   only true after [Inline_and_simplify] has split overapplications. *)
+
+(* CR-someday mshinwell: What about checks for shadowed variables and symbols? *)
+
+let variable_and_symbol_invariants (program : Flambda.program) =
+  let all_declared_variables = ref Variable.Set.empty in
+  let declare_variable var =
+    if Variable.Set.mem var !all_declared_variables then
+      raise (Binding_occurrence_of_variable_already_bound var);
+    all_declared_variables := Variable.Set.add var !all_declared_variables
+  in
+  let declare_variables vars =
+    Variable.Set.iter declare_variable vars
+  in
+  let all_declared_mutable_variables = ref Mutable_variable.Set.empty in
+  let declare_mutable_variable mut_var =
+    if Mutable_variable.Set.mem mut_var !all_declared_mutable_variables then
+      raise (Binding_occurrence_of_mutable_variable_already_bound mut_var);
+    all_declared_mutable_variables :=
+      Mutable_variable.Set.add mut_var !all_declared_mutable_variables
+  in
+  let add_binding_occurrence (var_env, mut_var_env, sym_env) var =
+    let compilation_unit = Compilation_unit.get_current_exn () in
+    if not (Variable.in_compilation_unit var compilation_unit) then
+      raise (Binding_occurrence_not_from_current_compilation_unit var);
+    declare_variable var;
+    Variable.Set.add var var_env, mut_var_env, sym_env
+  in
+  let add_mutable_binding_occurrence (var_env, mut_var_env, sym_env) mut_var =
+    let compilation_unit = Compilation_unit.get_current_exn () in
+    if not (Mutable_variable.in_compilation_unit mut_var compilation_unit) then
+      raise (Mutable_binding_occurrence_not_from_current_compilation_unit
+        mut_var);
+    declare_mutable_variable mut_var;
+    var_env, Mutable_variable.Set.add mut_var mut_var_env, sym_env
+  in
+  let add_binding_occurrence_of_symbol (var_env, mut_var_env, sym_env) sym =
+    if Symbol.Set.mem sym sym_env then
+      raise (Binding_occurrence_of_symbol_already_bound sym)
+    else
+      var_env, mut_var_env, Symbol.Set.add sym sym_env
+  in
+  let add_binding_occurrences env vars =
+    List.fold_left (fun env var -> add_binding_occurrence env var) env vars
+  in
+  let check_variable_is_bound (var_env, _, _) var =
+    if not (Variable.Set.mem var var_env) then raise (Unbound_variable var)
+  in
+  let check_symbol_is_bound (_, _, sym_env) sym =
+    if not (Symbol.Set.mem sym sym_env) then raise (Unbound_symbol sym)
+  in
+  let check_variables_are_bound env vars =
+    List.iter (check_variable_is_bound env) vars
+  in
+  let check_mutable_variable_is_bound (_, mut_var_env, _) mut_var =
+    if not (Mutable_variable.Set.mem mut_var mut_var_env) then begin
+      raise (Unbound_mutable_variable mut_var)
+    end
+  in
+  let rec loop env (flam : Flambda.t) =
+    match flam with
+    (* Expressions that can bind [Variable.t]s: *)
+    | Let { var; defining_expr; body; _ } ->
+      loop_named env defining_expr;
+      loop (add_binding_occurrence env var) body
+    | Let_mutable (mut_var, var, body) ->
+      check_variable_is_bound env var;
+      loop (add_mutable_binding_occurrence env mut_var) body
+    | Let_rec (defs, body) ->
+      let env =
+        List.fold_left (fun env (var, def) ->
+            will_traverse_named_expression_later def;
+            add_binding_occurrence env var)
+          env defs
+      in
+      List.iter (fun (var, def) ->
+        already_added_bound_variable_to_env var;
+        loop_named env def) defs;
+      loop env body
+    | For { bound_var; from_value; to_value; direction; body; } ->
+      ignore_direction_flag direction;
+      check_variable_is_bound env from_value;
+      check_variable_is_bound env to_value;
+      loop (add_binding_occurrence env bound_var) body
+    | Static_catch (static_exn, vars, body, handler) ->
+      ignore_static_exception static_exn;
+      loop env body;
+      loop (add_binding_occurrences env vars) handler
+    | Try_with (body, var, handler) ->
+      loop env body;
+      loop (add_binding_occurrence env var) handler
+    (* Everything else: *)
+    | Var var -> check_variable_is_bound env var
+    | Apply { func; args; kind; dbg; inline } ->
+      check_variable_is_bound env func;
+      check_variables_are_bound env args;
+      ignore_call_kind kind;
+      ignore_debuginfo dbg;
+      ignore_inline_attribute inline
+    | Assign { being_assigned; new_value; } ->
+      check_mutable_variable_is_bound env being_assigned;
+      check_variable_is_bound env new_value
+    | Send { kind; meth; obj; args; dbg; } ->
+      ignore_meth_kind kind;
+      check_variable_is_bound env meth;
+      check_variable_is_bound env obj;
+      check_variables_are_bound env args;
+      ignore_debuginfo dbg
+    | If_then_else (cond, ifso, ifnot) ->
+      check_variable_is_bound env cond;
+      loop env ifso;
+      loop env ifnot
+    | Switch (arg, { numconsts; consts; numblocks; blocks; failaction; }) ->
+      check_variable_is_bound env arg;
+      ignore_int_set numconsts;
+      ignore_int_set numblocks;
+      List.iter (fun (n, e) ->
+          ignore_int n;
+          loop env e)
+        (consts @ blocks);
+      Misc.may (loop env) failaction
+    | String_switch (arg, cases, e_opt) ->
+      check_variable_is_bound env arg;
+      List.iter (fun (label, case) ->
+          ignore_string label;
+          loop env case)
+        cases;
+      Misc.may (loop env) e_opt
+    | Static_raise (static_exn, es) ->
+      ignore_static_exception static_exn;
+      List.iter (check_variable_is_bound env) es
+    | While (e1, e2) ->
+      loop env e1;
+      loop env e2
+    | Proved_unreachable -> ()
+  and loop_named env (named : Flambda.named) =
+    match named with
+    | Symbol symbol -> check_symbol_is_bound env symbol
+    | Const const -> ignore_const const
+    | Allocated_const const -> ignore_allocated_const const
+    | Read_mutable mut_var ->
+      check_mutable_variable_is_bound env mut_var
+    | Read_symbol_field (symbol, index) ->
+      check_symbol_is_bound env symbol;
+      assert (index >= 0)  (* CR-someday mshinwell: add proper error *)
+    | Set_of_closures set_of_closures ->
+      loop_set_of_closures env set_of_closures
+    | Project_closure { set_of_closures; closure_id; } ->
+      check_variable_is_bound env set_of_closures;
+      ignore_closure_id closure_id
+    | Move_within_set_of_closures { closure; start_from; move_to; } ->
+      check_variable_is_bound env closure;
+      ignore_closure_id start_from;
+      ignore_closure_id move_to;
+    | Project_var { closure; closure_id; var; } ->
+      check_variable_is_bound env closure;
+      ignore_closure_id closure_id;
+      ignore_var_within_closure var
+    | Prim (prim, args, dbg) ->
+      ignore_primitive prim;
+      check_variables_are_bound env args;
+      ignore_debuginfo dbg
+    | Expr expr ->
+      loop env expr
+  and loop_set_of_closures env
+      ({ Flambda.function_decls; free_vars; specialised_args; }
+       as set_of_closures) =
+      let { Flambda.set_of_closures_id; funs; } = function_decls in
+      ignore_set_of_closures_id set_of_closures_id;
+      let functions_in_closure = Variable.Map.keys funs in
+      let variables_in_closure =
+        Variable.Map.fold (fun var var_in_closure variables_in_closure ->
+            (* [var] may occur in the body, but will effectively be renamed
+               to [var_in_closure], so the latter is what we check to make
+               sure it's bound. *)
+            ignore_variable var;
+            check_variable_is_bound env var_in_closure;
+            Variable.Set.add var variables_in_closure)
+          free_vars Variable.Set.empty
+      in
+      let all_params, all_free_vars =
+        Variable.Map.fold (fun fun_var function_decl acc ->
+            let all_params, all_free_vars = acc in
+            (* CR-soon mshinwell: check function_decl.all_symbols *)
+            let { Flambda.params; body; free_variables; stub; dbg; _ } =
+              function_decl
+            in
+            assert (Variable.Set.mem fun_var functions_in_closure);
+            ignore_bool stub;
+            ignore_debuginfo dbg;
+            (* Check that [free_variables], which is only present as an
+               optimization, is not lying. *)
+            let free_variables' = Flambda.free_variables body in
+            if not (Variable.Set.subset free_variables' free_variables) then
+              raise (Free_variables_set_is_lying (fun_var,
+                free_variables, free_variables', function_decl));
+            (* Check that every variable free in the body of the function is
+               bound by either the set of closures or the parameter list. *)
+            let acceptable_free_variables =
+              Variable.Set.union
+                (Variable.Set.union variables_in_closure functions_in_closure)
+                (Variable.Set.of_list params)
+            in
+            let bad =
+              Variable.Set.diff free_variables acceptable_free_variables
+            in
+            if not (Variable.Set.is_empty bad) then begin
+              raise (Vars_in_function_body_not_bound_by_closure_or_params
+                (bad, set_of_closures, fun_var))
+            end;
+            (* Check that parameters are unique across all functions in the
+               declaration. *)
+            let old_all_params_size = Variable.Set.cardinal all_params in
+            let params = Variable.Set.of_list params in
+            let params_size = Variable.Set.cardinal params in
+            let all_params = Variable.Set.union all_params params in
+            let all_params_size = Variable.Set.cardinal all_params in
+            if all_params_size <> old_all_params_size + params_size then begin
+              raise (Function_decls_have_overlapping_parameters all_params)
+            end;
+            (* Check that parameters and function variables are not
+               bound somewhere else in the program *)
+            declare_variables params;
+            declare_variable fun_var;
+            (* Check that the body of the functions is correctly structured *)
+            let body_env =
+              let (var_env, _, sym_env) = env in
+              let var_env =
+                Variable.Set.fold (fun var -> Variable.Set.add var)
+                  free_variables var_env
+              in
+              (* Mutable variables cannot be captured by closures *)
+              let mut_env = Mutable_variable.Set.empty in
+              (var_env, mut_env, sym_env)
+            in
+            loop body_env body;
+            all_params, Variable.Set.union free_variables all_free_vars)
+          funs (Variable.Set.empty, Variable.Set.empty)
+      in
+      (* CR-soon pchambart: This is not a property that we can certainly
+         ensure.
+         If the function get inlined, it is possible for the inlined version
+         to still use that variable. To be able to ensure that, we need to
+         also ensure that the inlined version will certainly be transformed
+         in a same way that can drop the dependency.
+         mshinwell: This should get some thought after the first release to
+         decide for sure what to do. *)
+      (* Check that the free variables rewriting map in the set of closures
+         does not contain variables in its domain that are not actually free
+         variables of any of the function bodies. *)
+      let bad_free_vars =
+        Variable.Set.diff (Variable.Map.keys free_vars) all_free_vars
+      in
+(*
+      if not (Variable.Set.is_empty bad_free_vars) then begin
+        raise (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars)
+      end;
+*)
+      (* Ignore it to avoid the warning: TODO get rid of that when the
+         case is settled *)
+      ignore (Set_of_closures_free_vars_map_has_wrong_range bad_free_vars);
+
+      (* Check that free variables variables are not bound somewhere
+         else in the program *)
+      declare_variables (Variable.Map.keys free_vars);
+      (* Check that every "specialised arg" is a parameter of one of the
+         functions being declared, and that the variable to which the
+         parameter is being specialised is bound. *)
+      Variable.Map.iter (fun being_specialised specialised_to ->
+          if not (Variable.Set.mem being_specialised all_params) then begin
+            raise (Specialised_arg_that_is_not_a_parameter being_specialised)
+          end;
+          check_variable_is_bound env specialised_to)
+        specialised_args
+  in
+  let loop_constant_defining_value env (const : Flambda.constant_defining_value) =
+    match const with
+    | Flambda.Allocated_const c ->
+      ignore_allocated_const c
+    | Flambda.Block (tag,fields) ->
+      ignore_tag tag;
+      List.iter (fun (fields : Flambda.constant_defining_value_block_field) ->
+          match fields with
+          | Const c -> ignore_const c
+          | Symbol s -> check_symbol_is_bound env s)
+        fields
+    | Flambda.Set_of_closures set_of_closures ->
+      loop_set_of_closures env set_of_closures;
+      (* Constant set of closures must not have free variables *)
+      if not (Variable.Map.is_empty set_of_closures.free_vars) then
+        assert false; (* TODO: correct error *)
+      if not (Variable.Map.is_empty set_of_closures.specialised_args) then
+        assert false; (* TODO: correct error *)
+    | Flambda.Project_closure (symbol,closure_id) ->
+      ignore_closure_id closure_id;
+      check_symbol_is_bound env symbol
+  in
+  let rec loop_program_body env (program : Flambda.program_body) =
+    match program with
+    | Let_rec_symbol (defs, program) ->
+      let env =
+        List.fold_left (fun env (symbol, _) ->
+            add_binding_occurrence_of_symbol env symbol)
+          env defs
+      in
+      List.iter (fun (_, def) ->
+          loop_constant_defining_value env def)
+        defs;
+      loop_program_body env program
+    | Let_symbol (symbol, def, program) ->
+      loop_constant_defining_value env def;
+      let env = add_binding_occurrence_of_symbol env symbol in
+      loop_program_body env program
+    | Initialize_symbol (symbol, _tag, fields, program) ->
+      List.iter (loop env) fields;
+      let env = add_binding_occurrence_of_symbol env symbol in
+      loop_program_body env program
+    | Effect (expr, program) ->
+      loop env expr;
+      loop_program_body env program
+    | End root ->
+      check_symbol_is_bound env root
+  in
+  let env =
+    Symbol.Set.fold (fun symbol env ->
+        add_binding_occurrence_of_symbol env symbol)
+      program.imported_symbols
+      (Variable.Set.empty, Mutable_variable.Set.empty, Symbol.Set.empty)
+  in
+  loop_program_body env program.program_body
+
+let primitive_invariants flam ~no_access_to_global_module_identifiers =
+  Flambda_iterators.iter_named (function
+      | Prim (prim, _, _) ->
+        begin match prim with
+        | Psequand | Psequor ->
+          raise (Sequential_logical_operator_primitives_must_be_expanded prim)
+        | Pgetglobal id ->
+          if no_access_to_global_module_identifiers
+            && not (Ident.is_predef_exn id) then
+          begin
+            raise (Access_to_global_module_identifier prim)
+          end
+        | Pidentity -> raise Pidentity_should_not_occur
+        | Pdirapply _ -> raise Pdirapply_should_be_expanded
+        | Prevapply _ -> raise Prevapply_should_be_expanded
+        | _ -> ()
+        end
+      | _ -> ())
+    flam
+
+let declared_var_within_closure (flam:Flambda.program) =
+  let bound = ref Var_within_closure.Set.empty in
+  let bound_multiple_times = ref None in
+  let add_and_check var =
+    if Var_within_closure.Set.mem var !bound then begin
+      bound_multiple_times := Some var
+    end;
+    bound := Var_within_closure.Set.add var !bound
+  in
+  Flambda_iterators.iter_on_set_of_closures_of_program
+    ~f:(fun ~constant:_ { Flambda. free_vars; _ } ->
+      Variable.Map.iter (fun id _ ->
+          let var = Var_within_closure.wrap id in
+          add_and_check var)
+        free_vars)
+    flam;
+  !bound, !bound_multiple_times
+
+let no_var_within_closure_is_bound_multiple_times (flam:Flambda.program) =
+  match declared_var_within_closure flam with
+  | _, Some var -> raise (Var_within_closure_bound_multiple_times var)
+  | _, None -> ()
+
+let every_declared_closure_is_from_current_compilation_unit flam =
+  let current_compilation_unit = Compilation_unit.get_current_exn () in
+  Flambda_iterators.iter_on_sets_of_closures (fun
+        { Flambda. function_decls; _ } ->
+      let compilation_unit =
+        Set_of_closures_id.get_compilation_unit
+          function_decls.set_of_closures_id
+      in
+      if not (Compilation_unit.equal compilation_unit current_compilation_unit)
+      then raise (Declared_closure_from_another_unit compilation_unit))
+    flam
+
+let declared_closure_ids program =
+  let bound = ref Closure_id.Set.empty in
+  let bound_multiple_times = ref None in
+  let add_and_check var =
+    if Closure_id.Set.mem var !bound
+    then bound_multiple_times := Some var;
+    bound := Closure_id.Set.add var !bound
+  in
+  Flambda_iterators.iter_on_set_of_closures_of_program program
+    ~f:(fun ~constant:_ { Flambda. function_decls; _; } ->
+        Variable.Map.iter (fun id _ ->
+            let var = Closure_id.wrap id in
+            add_and_check var)
+          function_decls.funs);
+  !bound, !bound_multiple_times
+
+let no_closure_id_is_bound_multiple_times program =
+  match declared_closure_ids program with
+  | _, Some closure_id ->
+    raise (Closure_id_is_bound_multiple_times closure_id)
+  | _, None -> ()
+
+let declared_set_of_closures_ids program =
+  let bound = ref Set_of_closures_id.Set.empty in
+  let bound_multiple_times = ref None in
+  let add_and_check var =
+    if Set_of_closures_id.Set.mem var !bound
+    then bound_multiple_times := Some var;
+    bound := Set_of_closures_id.Set.add var !bound
+  in
+  Flambda_iterators.iter_on_set_of_closures_of_program program
+    ~f:(fun ~constant:_ { Flambda. function_decls; _; } ->
+        add_and_check function_decls.set_of_closures_id);
+  !bound, !bound_multiple_times
+
+let no_set_of_closures_id_is_bound_multiple_times program =
+  match declared_set_of_closures_ids program with
+  | _, Some set_of_closures_id ->
+    raise (Set_of_closures_id_is_bound_multiple_times set_of_closures_id)
+  | _, None -> ()
+
+let used_closure_ids (program:Flambda.program) =
+  let used = ref Closure_id.Set.empty in
+  let f (flam : Flambda.named) =
+    match flam with
+    | Project_closure { closure_id; _} ->
+      used := Closure_id.Set.add closure_id !used;
+    | Move_within_set_of_closures { closure = _; start_from; move_to; } ->
+      used := Closure_id.Set.add start_from !used;
+      used := Closure_id.Set.add move_to !used
+    | Project_var { closure = _; closure_id; var = _ } ->
+      used := Closure_id.Set.add closure_id !used
+    | Set_of_closures _ | Symbol _ | Const _ | Allocated_const _
+    | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _ -> ()
+  in
+  (* TODO: check closure_ids of constant_defining_values project_closures *)
+  Flambda_iterators.iter_named_of_program ~f program;
+  !used
+
+let used_vars_within_closures (flam:Flambda.program) =
+  let used = ref Var_within_closure.Set.empty in
+  let f (flam : Flambda.named) =
+    match flam with
+    | Project_var { closure = _; closure_id = _; var; } ->
+      used := Var_within_closure.Set.add var !used
+    | _ -> ()
+  in
+  Flambda_iterators.iter_named_of_program ~f flam;
+  !used
+
+let every_used_function_from_current_compilation_unit_is_declared (program:Flambda.program) =
+  let current_compilation_unit = Compilation_unit.get_current_exn () in
+  let declared, _ = declared_closure_ids program in
+  let used = used_closure_ids program in
+  let used_from_current_unit =
+    Closure_id.Set.filter (fun cu ->
+        Closure_id.in_compilation_unit cu current_compilation_unit)
+      used
+  in
+  let counter_examples =
+    Closure_id.Set.diff used_from_current_unit declared
+  in
+  if Closure_id.Set.is_empty counter_examples
+  then ()
+  else raise (Unbound_closure_ids counter_examples)
+
+let every_used_var_within_closure_from_current_compilation_unit_is_declared
+      (flam:Flambda.program) =
+  let current_compilation_unit = Compilation_unit.get_current_exn () in
+  let declared, _ = declared_var_within_closure flam in
+  let used = used_vars_within_closures flam in
+  let used_from_current_unit =
+    Var_within_closure.Set.filter (fun cu ->
+        Var_within_closure.in_compilation_unit cu current_compilation_unit)
+      used
+  in
+  let counter_examples =
+    Var_within_closure.Set.diff used_from_current_unit declared in
+  if Var_within_closure.Set.is_empty counter_examples
+  then ()
+  else raise (Unbound_vars_within_closures counter_examples)
+
+let every_static_exception_is_caught flam =
+  let check env (flam : Flambda.t) =
+    match flam with
+    | Static_raise (exn, _) ->
+      if not (Static_exception.Set.mem exn env)
+      then raise (Static_exception_not_caught exn)
+    | _ -> ()
+  in
+  let rec loop env (flam : Flambda.t) =
+    match flam with
+    | Static_catch (i, _, body, handler) ->
+      let env = Static_exception.Set.add i env in
+      loop env handler;
+      loop env body
+    | exp ->
+      check env exp;
+      Flambda_iterators.apply_on_subexpressions (loop env)
+        (fun (_ : Flambda.named) -> ()) exp
+  in
+  loop Static_exception.Set.empty flam
+
+let every_static_exception_is_caught_at_a_single_position flam =
+  let caught = ref Static_exception.Set.empty in
+  let f (flam : Flambda.t) =
+    match flam with
+    | Static_catch (i, _, _body, _handler) ->
+      if Static_exception.Set.mem i !caught then
+        raise (Static_exception_caught_in_multiple_places i);
+      caught := Static_exception.Set.add i !caught
+    | _ -> ()
+  in
+  Flambda_iterators.iter f (fun (_ : Flambda.named) -> ()) flam
+
+let check_exn ?(kind=Normal) ?(cmxfile=false) (flam:Flambda.program) =
+  ignore kind;
+  try
+    variable_and_symbol_invariants flam;
+    no_closure_id_is_bound_multiple_times flam;
+    no_set_of_closures_id_is_bound_multiple_times flam;
+    every_used_function_from_current_compilation_unit_is_declared flam;
+    no_var_within_closure_is_bound_multiple_times flam;
+    every_used_var_within_closure_from_current_compilation_unit_is_declared flam;
+    Flambda_iterators.iter_exprs_at_toplevel_of_program flam ~f:(fun flam ->
+      primitive_invariants flam ~no_access_to_global_module_identifiers:cmxfile;
+      every_static_exception_is_caught flam;
+      every_static_exception_is_caught_at_a_single_position flam;
+      every_declared_closure_is_from_current_compilation_unit flam)
+  with exn -> begin
+  (* CR-someday split printing code into its own function *)
+    begin match exn with
+    | Binding_occurrence_not_from_current_compilation_unit var ->
+      Format.eprintf ">> Binding occurrence of variable marked as not being \
+          from the current compilation unit: %a"
+        Variable.print var
+    | Mutable_binding_occurrence_not_from_current_compilation_unit mut_var ->
+      Format.eprintf ">> Binding occurrence of mutable variable marked as not \
+          being from the current compilation unit: %a"
+        Mutable_variable.print mut_var
+    | Binding_occurrence_of_variable_already_bound var ->
+      Format.eprintf ">> Binding occurrence of variable that was already \
+            bound: %a"
+        Variable.print var
+    | Binding_occurrence_of_mutable_variable_already_bound mut_var ->
+      Format.eprintf ">> Binding occurrence of mutable variable that was already \
+            bound: %a"
+        Mutable_variable.print mut_var
+    | Binding_occurrence_of_symbol_already_bound sym ->
+      Format.eprintf ">> Binding occurrence of symbol that was already \
+            bound: %a"
+        Symbol.print sym
+    | Unbound_variable var ->
+      Format.eprintf ">> Unbound variable: %a" Variable.print var
+    | Unbound_mutable_variable mut_var ->
+      Format.eprintf ">> Unbound mutable variable: %a"
+        Mutable_variable.print mut_var
+    | Unbound_symbol sym ->
+      Format.eprintf ">> Unbound symbol: %a %s" Symbol.print sym (Printexc.raw_backtrace_to_string (Printexc.get_callstack 100))
+    | Vars_in_function_body_not_bound_by_closure_or_params
+        (vars, set_of_closures, fun_var) ->
+      Format.eprintf ">> Variable(s) (%a) in the body of a function declaration \
+          (fun_var = %a) that is not bound by either the closure or the function's \
+          parameter list.  Set of closures: %a"
+        Variable.Set.print vars
+        Variable.print fun_var
+        Flambda.print_set_of_closures set_of_closures
+    | Function_decls_have_overlapping_parameters vars ->
+      Format.eprintf ">> Function declarations whose parameters overlap: \
+          %a"
+        Variable.Set.print vars
+    | Specialised_arg_that_is_not_a_parameter var ->
+      Format.eprintf ">> Variable in [specialised_args] that is not a \
+          parameter of any of the function(s) in the corresponding \
+          declaration(s): %a"
+        Variable.print var
+    | Free_variables_set_is_lying (var, claimed, calculated, function_decl) ->
+      Format.eprintf ">> Function declaration whose [free_variables] set (%a) \
+          is not a superset of the result of [Flambda.free_variables] \
+          applied to the body of the function (%a).  Declaration: %a"
+        Variable.Set.print claimed
+        Variable.Set.print calculated
+        Flambda.print_function_declaration (var, function_decl)
+    | Set_of_closures_free_vars_map_has_wrong_range vars ->
+      Format.eprintf ">> [free_vars] map in set of closures has in its range \
+          variables that are not free variables of the corresponding \
+          functions: %a"
+        Variable.Set.print vars
+    | Sequential_logical_operator_primitives_must_be_expanded prim ->
+      Format.eprintf ">> Sequential logical operator primitives must be \
+          expanded (see closure_conversion.ml): %a"
+        Printlambda.primitive prim
+    | Var_within_closure_bound_multiple_times var ->
+      Format.eprintf ">> Variable within a closure is bound multiple times: \
+          %a"
+        Var_within_closure.print var
+    | Closure_id_is_bound_multiple_times closure_id ->
+      Format.eprintf ">> Closure ID is bound multiple times: %a"
+        Closure_id.print closure_id
+    | Set_of_closures_id_is_bound_multiple_times set_of_closures_id ->
+      Format.eprintf ">> Set of closures ID is bound multiple times: %a"
+        Set_of_closures_id.print set_of_closures_id
+    | Declared_closure_from_another_unit compilation_unit ->
+      Format.eprintf ">> Closure declared as being from another compilation \
+          unit: %a"
+        Compilation_unit.print compilation_unit
+    | Unbound_closure_ids closure_ids ->
+      Format.eprintf ">> Unbound closure ID(s) from the current compilation \
+          unit: %a"
+        Closure_id.Set.print closure_ids
+    | Unbound_vars_within_closures vars_within_closures ->
+      Format.eprintf ">> Unbound variable(s) within closure(s) from the \
+          current compilation_unit: %a"
+        Var_within_closure.Set.print vars_within_closures
+    | Static_exception_not_caught static_exn ->
+      Format.eprintf ">> Uncaught static exception: %a"
+        Static_exception.print static_exn
+    | Static_exception_caught_in_multiple_places static_exn ->
+      Format.eprintf ">> Static exception caught in multiple places: %a"
+        Static_exception.print static_exn
+    | Access_to_global_module_identifier prim ->
+      (* CR-someday mshinwell: backend-specific checks should move to another
+         module, in the asmcomp/ directory. *)
+      Format.eprintf ">> Forbidden access to a global module identifier (not \
+          allowed in Flambda that will be exported to a .cmx file): %a"
+        Printlambda.primitive prim
+    | Pidentity_should_not_occur ->
+      Format.eprintf ">> The Pidentity primitive should never occur in an \
+        Flambda expression (see closure_conversion.ml)"
+    | Pdirapply_should_be_expanded ->
+      Format.eprintf ">> The Pdirapply primitive should never occur in an \
+        Flambda expression (see closure_conversion.ml); use Apply instead"
+    | Prevapply_should_be_expanded ->
+      Format.eprintf ">> The Prevapply primitive should never occur in an \
+        Flambda expression (see closure_conversion.ml); use Apply instead"
+    | exn -> raise exn
+    end;
+    Format.eprintf "\n@?";
+    raise Flambda_invariants_failed
+  end

middle_end/flambda_invariants.mli

@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type flambda_kind =
+  | Normal
+  | Lifted
+
+(** Checking of invariants on Flambda expressions.  Raises an exception if
+    a check fails. *)
+val check_exn
+   : ?kind:flambda_kind
+  -> ?cmxfile:bool
+  -> Flambda.program
+  -> unit

middle_end/flambda_iterators.ml

@@ -0,0 +1,825 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+let apply_on_subexpressions f f_named (flam : Flambda.t) =
+  match flam with
+  | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable
+  | Static_raise _ -> ()
+  | Let { defining_expr; body; _ } ->
+    f_named defining_expr;
+    f body
+  | Let_mutable (_mut_var, _var, body) ->
+    f body
+  | Let_rec (defs, body) ->
+    List.iter (fun (_,l) -> f_named l) defs;
+    f body
+  | Switch (_, sw) ->
+    List.iter (fun (_,l) -> f l) sw.consts;
+    List.iter (fun (_,l) -> f l) sw.blocks;
+    Misc.may f sw.failaction
+  | String_switch (_, sw, def) ->
+    List.iter (fun (_,l) -> f l) sw;
+    Misc.may f def
+  | Static_catch (_,_,f1,f2) ->
+    f f1; f f2;
+  | Try_with (f1,_,f2) ->
+    f f1; f f2
+  | If_then_else (_,f1, f2) ->
+    f f1;f f2
+  | While (f1,f2) ->
+    f f1; f f2
+  | For { body; _ } -> f body
+
+let rec list_map_sharing f l =
+  match l with
+  | [] -> l
+  | h :: t ->
+    let new_t = list_map_sharing f t in
+    let new_h = f h in
+    if h == new_h && t == new_t then
+      l
+    else
+      new_h :: new_t
+
+let may_map_sharing f v =
+  match v with
+  | None -> v
+  | Some s ->
+    let new_s = f s in
+    if s == new_s then
+      v
+    else
+      Some new_s
+
+let map_snd_sharing f ((a, b) as cpl) =
+  let new_b = f a b in
+  if b == new_b then
+    cpl
+  else
+    (a, new_b)
+
+let map_subexpressions f f_named (tree:Flambda.t) : Flambda.t =
+  match tree with
+  | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable
+  | Static_raise _ -> tree
+  | Let { var; defining_expr; body; _ } ->
+    let new_named = f_named var defining_expr in
+    let new_body = f body in
+    if new_named == defining_expr && new_body == body then
+      tree
+    else
+      Flambda.create_let var new_named new_body
+  | Let_rec (defs, body) ->
+    let new_defs =
+      list_map_sharing (map_snd_sharing f_named) defs
+    in
+    let new_body = f body in
+    if new_defs == defs && new_body == body then
+      tree
+    else
+      Let_rec (new_defs, new_body)
+  | Let_mutable (mut_var, var, body) ->
+    let new_body = f body in
+    if new_body == body then
+      tree
+    else
+      Let_mutable (mut_var, var, new_body)
+  | Switch (arg, sw) ->
+    let aux = map_snd_sharing (fun _ v -> f v) in
+    let new_consts = list_map_sharing aux sw.consts in
+    let new_blocks = list_map_sharing aux sw.blocks in
+    let new_failaction = may_map_sharing f sw.failaction in
+    if sw.failaction == new_failaction &&
+       new_consts == sw.consts &&
+       new_blocks == sw.blocks then
+      tree
+    else
+      let sw =
+        { sw with
+          failaction = new_failaction;
+          consts = new_consts;
+          blocks = new_blocks;
+        }
+      in
+      Switch (arg, sw)
+  | String_switch (arg, sw, def) ->
+    let new_sw = list_map_sharing (map_snd_sharing (fun _ v -> f v)) sw in
+    let new_def = may_map_sharing f def in
+    if sw == new_sw && def == new_def then
+      tree
+    else
+      String_switch(arg, new_sw, new_def)
+  | Static_catch (i, vars, body, handler) ->
+    let new_body = f body in
+    let new_handler = f handler in
+    if new_body == body && new_handler == handler then
+      tree
+    else
+      Static_catch (i, vars, new_body, new_handler)
+  | Try_with(body, id, handler) ->
+    let new_body = f body in
+    let new_handler = f handler in
+    if body == new_body && handler == new_handler then
+      tree
+    else
+      Try_with(new_body, id, new_handler)
+  | If_then_else(arg, ifso, ifnot) ->
+    let new_ifso = f ifso in
+    let new_ifnot = f ifnot in
+    if new_ifso == ifso && new_ifnot == ifnot then
+      tree
+    else
+      If_then_else(arg, new_ifso, new_ifnot)
+  | While(cond, body) ->
+    let new_cond = f cond in
+    let new_body = f body in
+    if new_cond == cond && new_body == body then
+      tree
+    else
+      While(new_cond, new_body)
+  | For { bound_var; from_value; to_value; direction; body; } ->
+    let new_body = f body in
+    if new_body == body then
+      tree
+    else
+      For { bound_var; from_value; to_value; direction; body = new_body; }
+
+let iter_general = Flambda.iter_general
+
+let iter f f_named t = iter_general ~toplevel:false f f_named (Is_expr t)
+let iter_expr f t = iter f (fun _ -> ()) t
+let iter_on_named f f_named t =
+  iter_general ~toplevel:false f f_named (Is_named t)
+let iter_named f_named t = iter (fun (_ : Flambda.t) -> ()) f_named t
+let iter_named_on_named f_named named =
+  iter_general ~toplevel:false (fun (_ : Flambda.t) -> ()) f_named
+    (Is_named named)
+
+let iter_toplevel f f_named t = iter_general ~toplevel:true f f_named (Is_expr t)
+let iter_named_toplevel f f_named named =
+  iter_general ~toplevel:true f f_named (Is_named named)
+
+let iter_all_immutable_let_and_let_rec_bindings t ~f =
+  iter_expr (function
+      | Let { var; defining_expr; _ } -> f var defining_expr
+      | Let_rec (defs, _) -> List.iter (fun (var, named) -> f var named) defs
+      | _ -> ())
+    t
+
+let iter_all_toplevel_immutable_let_and_let_rec_bindings t ~f =
+  iter_general ~toplevel:true
+    (function
+      | Let { var; defining_expr; _ } -> f var defining_expr
+      | Let_rec (defs, _) -> List.iter (fun (var, named) -> f var named) defs
+      | _ -> ())
+    (fun _ -> ())
+    (Is_expr t)
+
+let iter_on_sets_of_closures f t =
+  iter_named (function
+      | Set_of_closures clos -> f clos
+      | Symbol _ | Const _ | Allocated_const _ | Read_mutable _
+      | Read_symbol_field _
+      | Project_closure _ | Move_within_set_of_closures _ | Project_var _
+      | Prim _ | Expr _ -> ())
+    t
+
+let iter_exprs_at_toplevel_of_program (program : Flambda.program) ~f =
+  let rec loop (program : Flambda.program_body) =
+    match program with
+    | Let_symbol (_, Set_of_closures set_of_closures, program) ->
+      Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) ->
+          f function_decl.body)
+        set_of_closures.function_decls.funs;
+      loop program
+    | Let_rec_symbol (defs, program) ->
+      List.iter (function
+          | (_, Flambda.Set_of_closures set_of_closures) ->
+            Variable.Map.iter
+              (fun _ (function_decl : Flambda.function_declaration) ->
+                f function_decl.body)
+              set_of_closures.function_decls.funs
+          | _ -> ()) defs;
+      loop program
+    | Let_symbol (_, _, program) ->
+      loop program
+    | Initialize_symbol (_, _, fields, program) ->
+      List.iter f fields;
+      loop program
+    | Effect (expr, program) ->
+      f expr;
+      loop program
+    | End _ -> ()
+  in
+  loop program.program_body
+
+let iter_named_of_program program ~f =
+  iter_exprs_at_toplevel_of_program program ~f:(iter_named f)
+
+let iter_on_set_of_closures_of_program (program : Flambda.program) ~f =
+  let rec loop (program : Flambda.program_body) =
+    match program with
+    | Let_symbol (_, Set_of_closures set_of_closures, program) ->
+      f ~constant:true set_of_closures;
+      Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) ->
+          iter_on_sets_of_closures (f ~constant:false) function_decl.body)
+        set_of_closures.function_decls.funs;
+      loop program
+    | Let_rec_symbol (defs, program) ->
+      List.iter (function
+          | (_, Flambda.Set_of_closures set_of_closures) ->
+            f ~constant:true set_of_closures;
+            Variable.Map.iter
+              (fun _ (function_decl : Flambda.function_declaration) ->
+                iter_on_sets_of_closures (f ~constant:false) function_decl.body)
+              set_of_closures.function_decls.funs
+          | _ -> ()) defs;
+      loop program
+    | Let_symbol (_, _, program) ->
+      loop program
+    | Initialize_symbol (_, _, fields, program) ->
+      List.iter (iter_on_sets_of_closures (f ~constant:false)) fields;
+      loop program
+    | Effect (expr, program) ->
+      iter_on_sets_of_closures (f ~constant:false) expr;
+      loop program
+    | End _ -> ()
+  in
+  loop program.program_body
+
+let iter_constant_defining_values_on_program (program : Flambda.program) ~f =
+  let rec loop (program : Flambda.program_body) =
+    match program with
+    | Let_symbol (_, const, program) ->
+      f const;
+      loop program
+    | Let_rec_symbol (defs, program) ->
+      List.iter (fun (_, const) -> f const) defs;
+      loop program
+    | Initialize_symbol (_, _, _, program) ->
+      loop program
+    | Effect (_, program) ->
+      loop program
+    | End _ -> ()
+  in
+  loop program.program_body
+
+let map_general ~toplevel f f_named tree =
+  let rec aux (tree : Flambda.t) =
+    match tree with
+    | Let _ ->
+      Flambda.map_lets tree ~for_defining_expr:aux_named ~for_last_body:aux
+        ~after_rebuild:f
+    | _ ->
+      let exp : Flambda.t =
+        match tree with
+        | Var _ | Apply _ | Assign _ | Send _ | Proved_unreachable
+        | Static_raise _ -> tree
+        | Let _ -> assert false
+        | Let_mutable (mut_var, var, body) ->
+          let new_body = aux body in
+          if new_body == body then
+            tree
+          else
+            Let_mutable (mut_var, var, new_body)
+        | Let_rec (defs, body) ->
+          let done_something = ref false in
+          let defs =
+            List.map (fun (id, lam) ->
+                id, aux_named_done_something id lam done_something)
+              defs
+          in
+          let body = aux_done_something body done_something in
+          if not !done_something then
+            tree
+          else
+            Let_rec (defs, body)
+        | Switch (arg, sw) ->
+          let done_something = ref false in
+          let sw =
+            { sw with
+              failaction =
+                begin match sw.failaction with
+                | None -> None
+                | Some failaction ->
+                  Some (aux_done_something failaction done_something)
+                end;
+              consts =
+                List.map (fun (i, v) ->
+                    i, aux_done_something v done_something)
+                  sw.consts;
+              blocks =
+                List.map (fun (i, v) ->
+                    i, aux_done_something v done_something)
+                  sw.blocks;
+            }
+          in
+          if not !done_something then
+            tree
+          else
+            Switch (arg, sw)
+        | String_switch (arg, sw, def) ->
+          let done_something = ref false in
+          let sw =
+            List.map (fun (i, v) -> i, aux_done_something v done_something) sw
+          in
+          let def =
+            match def with
+            | None -> None
+            | Some def -> Some (aux_done_something def done_something)
+          in
+          if not !done_something then
+            tree
+          else
+            String_switch(arg, sw, def)
+        | Static_catch (i, vars, body, handler) ->
+          let new_body = aux body in
+          let new_handler = aux handler in
+          if new_body == body && new_handler == handler then
+            tree
+          else
+            Static_catch (i, vars, new_body, new_handler)
+        | Try_with(body, id, handler) ->
+          let new_body = aux body in
+          let new_handler = aux handler in
+          if new_body == body && new_handler == handler then
+            tree
+          else
+            Try_with (new_body, id, new_handler)
+        | If_then_else (arg, ifso, ifnot) ->
+          let new_ifso = aux ifso in
+          let new_ifnot = aux ifnot in
+          if new_ifso == ifso && new_ifnot == ifnot then
+            tree
+          else
+            If_then_else (arg, new_ifso, new_ifnot)
+        | While (cond, body) ->
+          let new_cond = aux cond in
+          let new_body = aux body in
+          if new_cond == cond && new_body == body then
+            tree
+          else
+            While (new_cond, new_body)
+        | For { bound_var; from_value; to_value; direction; body; } ->
+          let new_body = aux body in
+          if new_body == body then
+            tree
+          else
+            For { bound_var; from_value; to_value; direction;
+              body = new_body; }
+      in
+      f exp
+  and aux_done_something expr done_something =
+    let new_expr = aux expr in
+    if not (new_expr == expr) then begin
+      done_something := true
+    end;
+    new_expr
+  and aux_named (id : Variable.t) (named : Flambda.named) =
+    let named : Flambda.named =
+      match named with
+      | Symbol _ | Const _ | Allocated_const _ | Read_mutable _
+      | Project_closure _ | Move_within_set_of_closures _ | Project_var _
+      | Prim _ | Read_symbol_field _ -> named
+      | Set_of_closures ({ function_decls; free_vars; specialised_args }) ->
+        if toplevel then named
+        else begin
+          let done_something = ref false in
+          let funs =
+            Variable.Map.map (fun (func_decl : Flambda.function_declaration) ->
+                let new_body = aux func_decl.body in
+                if new_body == func_decl.body then begin
+                  func_decl
+                end else begin
+                  done_something := true;
+                  Flambda.create_function_declaration
+                    ~params:func_decl.params
+                    ~body:new_body
+                    ~stub:func_decl.stub
+                    ~dbg:func_decl.dbg
+                    ~inline:func_decl.inline
+                    ~is_a_functor:func_decl.is_a_functor
+                end)
+              function_decls.funs
+          in
+          if not !done_something then
+            named
+          else
+            let function_decls =
+              Flambda.update_function_declarations function_decls ~funs
+            in
+            let set_of_closures =
+              Flambda.create_set_of_closures ~function_decls ~free_vars
+                ~specialised_args
+            in
+            Set_of_closures set_of_closures
+        end
+      | Expr expr ->
+        let new_expr = aux expr in
+        if new_expr == expr then named
+        else Expr new_expr
+    in
+    f_named id named
+  and aux_named_done_something id named done_something =
+    let new_named = aux_named id named in
+    if not (new_named == named) then begin
+      done_something := true
+    end;
+    new_named
+  in
+  aux tree
+
+let iter_apply_on_program program ~f =
+  iter_exprs_at_toplevel_of_program program ~f:(fun expr ->
+    iter (function
+        | Apply apply -> f apply
+        | _ -> ())
+      (fun _ -> ())
+      expr)
+
+let map f f_named tree = map_general ~toplevel:false f (fun _ n -> f_named n) tree
+let map_expr f tree = map f (fun named -> named) tree
+let map_named f_named tree = map (fun expr -> expr) f_named tree
+let map_named_with_id f_named tree =
+  map_general ~toplevel:false (fun expr -> expr) f_named tree
+let map_toplevel f f_named tree =
+  map_general ~toplevel:true f (fun _ n -> f_named n) tree
+let map_toplevel_expr f_expr tree =
+  map_toplevel f_expr (fun named -> named) tree
+let map_toplevel_named f_named tree =
+  map_toplevel (fun tree -> tree) f_named tree
+
+let map_symbols tree ~f =
+  map_named (function
+      | (Symbol sym) as named ->
+        let new_sym = f sym in
+        if new_sym == sym then
+          named
+        else
+          Symbol new_sym
+      | ((Read_symbol_field (sym, field)) as named) ->
+        let new_sym = f sym in
+        if new_sym == sym then
+          named
+        else
+          Read_symbol_field (new_sym, field)
+      | (Const _ | Allocated_const _ | Set_of_closures _ | Read_mutable _
+      | Project_closure _ | Move_within_set_of_closures _ | Project_var _
+      | Prim _ | Expr _) as named -> named)
+    tree
+
+let map_symbols_on_set_of_closures
+    ({ Flambda.function_decls; free_vars; specialised_args } as
+      set_of_closures)
+    ~f =
+  let done_something = ref false in
+  let funs =
+    Variable.Map.map (fun (func_decl : Flambda.function_declaration) ->
+        let body = map_symbols func_decl.body ~f in
+        if not (body == func_decl.body) then begin
+          done_something := true;
+        end;
+        Flambda.create_function_declaration
+          ~params:func_decl.params
+          ~body
+          ~stub:func_decl.stub
+          ~dbg:func_decl.dbg
+          ~inline:func_decl.inline
+          ~is_a_functor:func_decl.is_a_functor)
+      function_decls.funs
+  in
+  if not !done_something then
+    set_of_closures
+  else
+    let function_decls =
+      Flambda.update_function_declarations function_decls ~funs
+    in
+    Flambda.create_set_of_closures ~function_decls ~free_vars
+      ~specialised_args
+
+let map_toplevel_sets_of_closures tree ~f =
+  map_toplevel_named (function
+      | (Set_of_closures set_of_closures) as named ->
+        let new_set_of_closures = f set_of_closures in
+        if new_set_of_closures == set_of_closures then
+          named
+        else
+          Set_of_closures new_set_of_closures
+      | (Symbol _ | Const _ | Allocated_const _ | Read_mutable _
+      | Read_symbol_field _
+      | Project_closure _ | Move_within_set_of_closures _ | Project_var _
+      | Prim _ | Expr _) as named -> named)
+    tree
+
+let map_apply tree ~f =
+  map (function
+      | (Apply apply) as expr ->
+        let new_apply = f apply in
+        if new_apply == apply then
+          expr
+        else
+          Apply new_apply
+      | expr -> expr)
+    (fun named -> named)
+    tree
+
+let map_sets_of_closures tree ~f =
+  map_named (function
+      | (Set_of_closures set_of_closures) as named ->
+        let new_set_of_closures = f set_of_closures in
+        if new_set_of_closures == set_of_closures then
+          named
+        else
+          Set_of_closures new_set_of_closures
+      | (Symbol _ | Const _ | Allocated_const _ | Project_closure _
+      | Move_within_set_of_closures _ | Project_var _
+      | Prim _ | Expr _ | Read_mutable _
+      | Read_symbol_field _) as named -> named)
+    tree
+
+let map_project_var_to_expr_opt tree ~f =
+  map_named (function
+      | (Project_var project_var) as named ->
+        begin match f project_var with
+        | None -> named
+        | Some expr -> Expr expr
+        end
+      | (Symbol _ | Const _ | Allocated_const _
+      | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _
+      | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _)
+          as named -> named)
+    tree
+
+let map_toplevel_project_var_to_expr_opt tree ~f =
+  map_toplevel_named (function
+      | (Project_var project_var) as named ->
+        begin match f project_var with
+        | None -> named
+        | Some expr -> Expr expr
+        end
+      | (Symbol _ | Const _ | Allocated_const _
+      | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _
+      | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _)
+          as named -> named)
+    tree
+
+let map_project_var_to_named_opt tree ~f =
+  map_named (function
+      | (Project_var project_var) as named ->
+        begin match f project_var with
+        | None -> named
+        | Some named -> named
+        end
+      | (Symbol _ | Const _ | Allocated_const _
+      | Set_of_closures _ | Project_closure _ | Move_within_set_of_closures _
+      | Prim _ | Expr _ | Read_mutable _ | Read_symbol_field _)
+          as named -> named)
+    tree
+
+let map_function_bodies (set_of_closures : Flambda.set_of_closures) ~f =
+  let done_something = ref false in
+  let funs =
+    Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
+        let new_body = f function_decl.body in
+        if new_body == function_decl.body then
+          function_decl
+        else begin
+          done_something := true;
+          Flambda.create_function_declaration ~body:new_body
+            ~params:function_decl.params
+            ~stub:function_decl.stub
+            ~dbg:function_decl.dbg
+            ~inline:function_decl.inline
+            ~is_a_functor:function_decl.is_a_functor
+        end)
+      set_of_closures.function_decls.funs
+  in
+  if not !done_something then
+    set_of_closures
+  else
+    let function_decls =
+      Flambda.update_function_declarations set_of_closures.function_decls ~funs
+    in
+    Flambda.create_set_of_closures
+      ~function_decls
+      ~free_vars:set_of_closures.free_vars
+      ~specialised_args:set_of_closures.specialised_args
+
+let map_sets_of_closures_of_program (program : Flambda.program)
+    ~(f : Flambda.set_of_closures -> Flambda.set_of_closures) =
+  let rec loop (program : Flambda.program_body) : Flambda.program_body =
+    let map_constant_set_of_closures (set_of_closures:Flambda.set_of_closures) =
+      let done_something = ref false in
+      let function_decls =
+        let funs =
+          Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
+              let body = map_sets_of_closures ~f function_decl.body in
+              if body == function_decl.body then
+                function_decl
+              else begin
+                done_something := true;
+                Flambda.create_function_declaration ~body
+                  ~params:function_decl.params
+                  ~stub:function_decl.stub
+                  ~dbg:function_decl.dbg
+                  ~inline:function_decl.inline
+                  ~is_a_functor:function_decl.is_a_functor
+              end)
+            set_of_closures.function_decls.funs
+        in
+        if not !done_something then
+          set_of_closures.function_decls
+        else
+          Flambda.update_function_declarations set_of_closures.function_decls
+            ~funs
+      in
+      let new_set_of_closures = f set_of_closures in
+      if new_set_of_closures == set_of_closures then
+        set_of_closures
+      else
+        Flambda.create_set_of_closures ~function_decls
+          ~free_vars:set_of_closures.free_vars
+          ~specialised_args:set_of_closures.specialised_args
+    in
+    match program with
+    | Let_symbol (symbol, Set_of_closures set_of_closures, program') ->
+      let new_set_of_closures = map_constant_set_of_closures set_of_closures in
+      let new_program' = loop program' in
+      if new_set_of_closures == set_of_closures
+          && new_program' == program' then
+        program
+      else
+        Let_symbol (symbol, Set_of_closures new_set_of_closures, new_program')
+    | Let_symbol (symbol, const, program') ->
+      let new_program' = loop program' in
+      if new_program' == program' then
+        program
+      else
+        Let_symbol (symbol, const, new_program')
+    | Let_rec_symbol (defs, program') ->
+      let done_something = ref false in
+      let defs =
+        List.map (function
+            | (var, Flambda.Set_of_closures set_of_closures) ->
+              let new_set_of_closures =
+                map_constant_set_of_closures set_of_closures
+              in
+              if not (new_set_of_closures == set_of_closures) then begin
+                done_something := true
+              end;
+              var, Flambda.Set_of_closures new_set_of_closures
+            | def -> def)
+          defs
+      in
+      let new_program' = loop program' in
+      if new_program' == program' && not !done_something then
+        program
+      else
+        Let_rec_symbol (defs, loop program')
+    | Initialize_symbol (symbol, tag, fields, program') ->
+      let done_something = ref false in
+      let fields =
+        List.map (fun field ->
+            let new_field = map_sets_of_closures field ~f in
+            if not (new_field == field) then begin
+              done_something := true
+            end;
+            new_field)
+          fields
+      in
+      let new_program' = loop program' in
+      if new_program' == program' && not !done_something then
+        program
+      else
+        Initialize_symbol (symbol, tag, fields, new_program')
+    | Effect (expr, program') ->
+      let new_expr = map_sets_of_closures expr ~f in
+      let new_program' = loop program' in
+      if new_expr == expr && new_program' == program' then
+        program
+      else
+        Effect (new_expr, new_program')
+    | End _ -> program
+  in
+  { program with
+    program_body = loop program.program_body;
+  }
+
+let map_exprs_at_toplevel_of_program (program : Flambda.program)
+    ~(f : Flambda.t -> Flambda.t) =
+  let rec loop (program : Flambda.program_body) : Flambda.program_body =
+    let map_constant_set_of_closures (set_of_closures:Flambda.set_of_closures) =
+      let done_something = ref false in
+      let funs =
+        Variable.Map.map (fun (function_decl : Flambda.function_declaration) ->
+            let body = f function_decl.body in
+            if body == function_decl.body then
+              function_decl
+            else begin
+              done_something := true;
+              Flambda.create_function_declaration ~body
+                ~params:function_decl.params
+                ~stub:function_decl.stub
+                ~dbg:function_decl.dbg
+                ~inline:function_decl.inline
+                ~is_a_functor:function_decl.is_a_functor
+            end)
+          set_of_closures.function_decls.funs
+      in
+      if not !done_something then
+        set_of_closures
+      else
+        let function_decls =
+          Flambda.update_function_declarations set_of_closures.function_decls
+            ~funs
+        in
+        Flambda.create_set_of_closures ~function_decls
+          ~free_vars:set_of_closures.free_vars
+          ~specialised_args:set_of_closures.specialised_args
+    in
+    (* CR-soon mshinwell: code very similar to the above function *)
+    match program with
+    | Let_symbol (symbol, Set_of_closures set_of_closures, program') ->
+      let new_set_of_closures = map_constant_set_of_closures set_of_closures in
+      let new_program' = loop program' in
+      if new_set_of_closures == set_of_closures
+          && new_program' == program' then
+        program
+      else
+        Let_symbol (symbol, Set_of_closures new_set_of_closures, new_program')
+    | Let_symbol (symbol, const, program') ->
+      let new_program' = loop program' in
+      if new_program' == program' then
+        program
+      else
+        Let_symbol (symbol, const, new_program')
+    | Let_rec_symbol (defs, program') ->
+      let done_something = ref false in
+      let defs =
+        List.map (function
+            | (var, Flambda.Set_of_closures set_of_closures) ->
+              let new_set_of_closures =
+                map_constant_set_of_closures set_of_closures
+              in
+              if not (new_set_of_closures == set_of_closures) then begin
+                done_something := true
+              end;
+              var, Flambda.Set_of_closures new_set_of_closures
+            | def -> def)
+          defs
+      in
+      let new_program' = loop program' in
+      if new_program' == program' && not !done_something then
+        program
+      else
+        Let_rec_symbol (defs, new_program')
+    | Initialize_symbol (symbol, tag, fields, program') ->
+      let done_something = ref false in
+      let fields =
+        List.map (fun field ->
+            let new_field = f field in
+            if not (new_field == field) then begin
+              done_something := true
+            end;
+            new_field)
+          fields
+      in
+      let new_program' = loop program' in
+      if new_program' == program' && not !done_something then
+        program
+      else
+        Initialize_symbol (symbol, tag, fields, new_program')
+    | Effect (expr, program') ->
+      let new_expr = f expr in
+      let new_program' = loop program' in
+      if new_expr == expr && new_program' == program' then
+        program
+      else
+        Effect (new_expr, new_program')
+    | End _ -> program
+  in
+  { program with
+    program_body = loop program.program_body;
+  }
+
+let map_named_of_program (program : Flambda.program)
+      ~(f : Variable.t -> Flambda.named -> Flambda.named) : Flambda.program =
+  map_exprs_at_toplevel_of_program program
+      ~f:(fun expr -> map_named_with_id f expr)
+
+let map_all_immutable_let_and_let_rec_bindings (expr : Flambda.t)
+      ~(f : Variable.t -> Flambda.named -> Flambda.named) : Flambda.t =
+  map_named_with_id f expr

middle_end/flambda_iterators.mli

@@ -0,0 +1,221 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* CR-soon mshinwell: we need to document whether these iterators follow any
+   particular order. *)
+
+(** Apply the given functions to the immediate subexpressions of the given
+    Flambda expression.  For avoidance of doubt, if a subexpression is
+    [Expr], it is passed to the function taking [Flambda.named], rather
+    than being followed and passed to the function taking [Flambda.t]. *)
+val apply_on_subexpressions
+   : (Flambda.t -> unit)
+  -> (Flambda.named -> unit)
+  -> Flambda.t
+  -> unit
+
+val map_subexpressions
+   : (Flambda.t -> Flambda.t)
+  -> (Variable.t -> Flambda.named -> Flambda.named)
+  -> Flambda.t
+  -> Flambda.t
+
+(* CR-soon lwhite: add comment to clarify that these recurse unlike the
+   ones above *)
+val iter
+   : (Flambda.t -> unit)
+  -> (Flambda.named -> unit)
+  -> Flambda.t
+  -> unit
+
+val iter_expr
+   : (Flambda.t -> unit)
+  -> Flambda.t
+  -> unit
+
+val iter_on_named
+   : (Flambda.t -> unit)
+  -> (Flambda.named -> unit)
+  -> Flambda.named
+  -> unit
+
+(* CR-someday mshinwell: we might need to add the corresponding variable to
+   the parameters of the user function for [iter_named] *)
+val iter_named
+   : (Flambda.named -> unit)
+  -> Flambda.t
+  -> unit
+
+(* CR-someday lwhite: These names are pretty indecipherable, perhaps
+   create submodules for the normal and "on_named" variants of each
+   function. *)
+
+val iter_named_on_named
+   : (Flambda.named -> unit)
+  -> Flambda.named
+  -> unit
+
+(** [iter_toplevel f t] applies [f] on every toplevel subexpression of [t].
+    In particular, it never applies [f] to the body of a function (which
+    will always be contained within an [Set_of_closures] expression). *)
+val iter_toplevel
+   : (Flambda.t -> unit)
+  -> (Flambda.named -> unit)
+  -> Flambda.t
+  -> unit
+
+val iter_named_toplevel
+   : (Flambda.t -> unit)
+  -> (Flambda.named -> unit)
+  -> Flambda.named
+  -> unit
+
+val iter_on_sets_of_closures
+   : (Flambda.set_of_closures -> unit)
+  -> Flambda.t
+  -> unit
+
+val iter_on_set_of_closures_of_program
+   : Flambda.program
+  -> f:(constant:bool -> Flambda.set_of_closures -> unit)
+  -> unit
+
+val iter_all_immutable_let_and_let_rec_bindings
+   : Flambda.t
+  -> f:(Variable.t -> Flambda.named -> unit)
+  -> unit
+
+val iter_all_toplevel_immutable_let_and_let_rec_bindings
+   : Flambda.t
+  -> f:(Variable.t -> Flambda.named -> unit)
+  -> unit
+
+val iter_exprs_at_toplevel_of_program
+   : Flambda.program
+  -> f:(Flambda.t -> unit)
+  -> unit
+
+val iter_named_of_program
+   : Flambda.program
+  -> f:(Flambda.named -> unit)
+  -> unit
+
+val iter_constant_defining_values_on_program
+  : Flambda.program
+  -> f:(Flambda.constant_defining_value -> unit)
+  -> unit
+
+val iter_apply_on_program
+   : Flambda.program
+  -> f:(Flambda.apply -> unit)
+  -> unit
+
+val map
+   : (Flambda.t -> Flambda.t)
+  -> (Flambda.named -> Flambda.named)
+  -> Flambda.t
+  -> Flambda.t
+
+val map_expr
+   : (Flambda.t -> Flambda.t)
+  -> Flambda.t
+  -> Flambda.t
+
+val map_named
+   : (Flambda.named -> Flambda.named)
+  -> Flambda.t
+  -> Flambda.t
+
+val map_toplevel
+   : (Flambda.t -> Flambda.t)
+  -> (Flambda.named -> Flambda.named)
+  -> Flambda.t
+  -> Flambda.t
+
+val map_toplevel_expr
+   : (Flambda.t -> Flambda.t)
+  -> Flambda.t
+  -> Flambda.t
+
+val map_toplevel_named
+   : (Flambda.named -> Flambda.named)
+  -> Flambda.t
+  -> Flambda.t
+
+val map_symbols
+   : Flambda.t
+  -> f:(Symbol.t -> Symbol.t)
+  -> Flambda.t
+
+val map_symbols_on_set_of_closures
+  : Flambda.set_of_closures
+  -> f:(Symbol.t -> Symbol.t)
+  -> Flambda.set_of_closures
+
+val map_toplevel_sets_of_closures
+   : Flambda.t
+  -> f:(Flambda.set_of_closures -> Flambda.set_of_closures)
+  -> Flambda.t
+
+val map_apply
+   : Flambda.t
+  -> f:(Flambda.apply -> Flambda.apply)
+  -> Flambda.t
+
+val map_function_bodies
+   : Flambda.set_of_closures
+  -> f:(Flambda.t -> Flambda.t)
+  -> Flambda.set_of_closures
+
+val map_sets_of_closures
+   : Flambda.t
+  -> f:(Flambda.set_of_closures -> Flambda.set_of_closures)
+  -> Flambda.t
+
+val map_sets_of_closures_of_program
+   : Flambda.program
+  -> f:(Flambda.set_of_closures -> Flambda.set_of_closures)
+  -> Flambda.program
+
+val map_project_var_to_expr_opt
+   : Flambda.t
+  -> f:(Flambda.project_var -> Flambda.t option)
+  -> Flambda.t
+
+val map_toplevel_project_var_to_expr_opt
+   : Flambda.t
+  -> f:(Flambda.project_var -> Flambda.t option)
+  -> Flambda.t
+
+val map_project_var_to_named_opt
+   : Flambda.t
+  -> f:(Flambda.project_var -> Flambda.named option)
+  -> Flambda.t
+
+val map_exprs_at_toplevel_of_program
+   : Flambda.program
+  -> f:(Flambda.t -> Flambda.t)
+  -> Flambda.program
+
+val map_named_of_program
+   : Flambda.program
+  -> f:(Variable.t -> Flambda.named -> Flambda.named)
+  -> Flambda.program
+
+val map_all_immutable_let_and_let_rec_bindings
+   : Flambda.t
+  -> f:(Variable.t -> Flambda.named -> Flambda.named)
+  -> Flambda.t

middle_end/flambda_utils.ml

@@ -0,0 +1,754 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+let find_declaration cf ({ funs } : Flambda.function_declarations) =
+  Variable.Map.find (Closure_id.unwrap cf) funs
+
+let find_declaration_variable cf ({ funs } : Flambda.function_declarations) =
+  let var = Closure_id.unwrap cf in
+  if not (Variable.Map.mem var funs)
+  then raise Not_found
+  else var
+
+let find_free_variable cv ({ free_vars } : Flambda.set_of_closures) =
+  Variable.Map.find (Var_within_closure.unwrap cv) free_vars
+
+let function_arity (f : Flambda.function_declaration) = List.length f.params
+
+let variables_bound_by_the_closure cf
+      (decls : Flambda.function_declarations) =
+  let func = find_declaration cf decls in
+  let params = Variable.Set.of_list func.params in
+  let functions = Variable.Map.keys decls.funs in
+  Variable.Set.diff
+    (Variable.Set.diff func.free_variables params)
+    functions
+
+let description_of_toplevel_node (expr : Flambda.t) =
+  match expr with
+  | Var id -> Format.asprintf "var %a" Variable.print id
+  | Apply _ -> "apply"
+  | Assign _ -> "assign"
+  | Send _ -> "send"
+  | Proved_unreachable -> "unreachable"
+  | Let { var; _ } -> Format.asprintf "let %a" Variable.print var
+  | Let_mutable _ -> "let_mutable"
+  | Let_rec _ -> "letrec"
+  | If_then_else _ -> "if"
+  | Switch _ -> "switch"
+  | String_switch _ -> "stringswitch"
+  | Static_raise  _ -> "staticraise"
+  | Static_catch  _ -> "catch"
+  | Try_with _ -> "trywith"
+  | While _ -> "while"
+  | For _ -> "for"
+
+let compare_const (c1 : Flambda.const) (c2 : Flambda.const) =
+  match c1, c2 with
+  | Int v1, Int v2 -> compare v1 v2
+  | Char v1, Char v2 -> compare v1 v2
+  | Const_pointer v1, Const_pointer v2 -> compare v1 v2
+  | Int _, _ -> -1
+  | _, Int _ -> 1
+  | Char _, _ -> -1
+  | _, Char _ -> 1
+
+let rec same (l1 : Flambda.t) (l2 : Flambda.t) =
+  l1 == l2 || (* it is ok for the string case: if they are physically the same,
+                 it is the same original branch *)
+  match (l1, l2) with
+  | Var v1 , Var v2  -> Variable.equal v1 v2
+  | Var _, _ | _, Var _ -> false
+  | Apply a1 , Apply a2  ->
+    a1.kind = a2.kind
+      && Variable.equal a1.func a2.func
+      && Misc.samelist Variable.equal a1.args a2.args
+  | Apply _, _ | _, Apply _ -> false
+  | Let { var = var1; defining_expr = defining_expr1; body = body1; _ },
+      Let { var = var2; defining_expr = defining_expr2; body = body2; _ } ->
+    Variable.equal var1 var2 && same_named defining_expr1 defining_expr2
+      && same body1 body2
+  | Let _, _ | _, Let _ -> false
+  | Let_mutable (mv1, v1, b1), Let_mutable (mv2, v2, b2) ->
+    Mutable_variable.equal mv1 mv2
+      && Variable.equal v1 v2
+      && same b1 b2
+  | Let_mutable _, _ | _, Let_mutable _ -> false
+  | Let_rec (bl1, a1), Let_rec (bl2, a2) ->
+    Misc.samelist samebinding bl1 bl2 && same a1 a2
+  | Let_rec _, _ | _, Let_rec _ -> false
+  | Switch (a1, s1), Switch (a2, s2) ->
+    Variable.equal a1 a2 && sameswitch s1 s2
+  | Switch _, _ | _, Switch _ -> false
+  | String_switch (a1, s1, d1), String_switch (a2, s2, d2) ->
+    Variable.equal a1 a2 &&
+      Misc.samelist (fun (s1, e1) (s2, e2) -> s1 = s2 && same e1 e2) s1 s2 &&
+      Misc.sameoption same d1 d2
+  | String_switch _, _ | _, String_switch _ -> false
+  | Static_raise (e1, a1), Static_raise (e2, a2) ->
+    Static_exception.equal e1 e2 && Misc.samelist Variable.equal a1 a2
+  | Static_raise _, _ | _, Static_raise _ -> false
+  | Static_catch (s1, v1, a1, b1), Static_catch (s2, v2, a2, b2) ->
+    Static_exception.equal s1 s2 && Misc.samelist Variable.equal v1 v2 &&
+      same a1 a2 && same b1 b2
+  | Static_catch _, _ | _, Static_catch _ -> false
+  | Try_with (a1, v1, b1), Try_with (a2, v2, b2) ->
+    same a1 a2 && Variable.equal v1 v2 && same b1 b2
+  | Try_with _, _ | _, Try_with _ -> false
+  | If_then_else (a1, b1, c1), If_then_else (a2, b2, c2) ->
+    Variable.equal a1 a2 && same b1 b2 && same c1 c2
+  | If_then_else _, _ | _, If_then_else _ -> false
+  | While (a1, b1), While (a2, b2) ->
+    same a1 a2 && same b1 b2
+  | While _, _ | _, While _ -> false
+  | For { bound_var = bound_var1; from_value = from_value1;
+          to_value = to_value1; direction = direction1; body = body1; },
+    For { bound_var = bound_var2; from_value = from_value2;
+          to_value = to_value2; direction = direction2; body = body2; } ->
+    Variable.equal bound_var1 bound_var2
+      && Variable.equal from_value1 from_value2
+      && Variable.equal to_value1 to_value2
+      && direction1 = direction2
+      && same body1 body2
+  | For _, _ | _, For _ -> false
+  | Assign { being_assigned = being_assigned1; new_value = new_value1; },
+    Assign { being_assigned = being_assigned2; new_value = new_value2; } ->
+    Mutable_variable.equal being_assigned1 being_assigned2
+      && Variable.equal new_value1 new_value2
+  | Assign _, _ | _, Assign _ -> false
+  | Send { kind = kind1; meth = meth1; obj = obj1; args = args1; dbg = _; },
+    Send { kind = kind2; meth = meth2; obj = obj2; args = args2; dbg = _; } ->
+    kind1 = kind2
+      && Variable.equal meth1 meth2
+      && Variable.equal obj1 obj2
+      && Misc.samelist Variable.equal args1 args2
+  | Send _, _ | _, Send _ -> false
+  | Proved_unreachable, Proved_unreachable -> true
+
+and same_named (named1 : Flambda.named) (named2 : Flambda.named) =
+  match named1, named2 with
+  | Symbol s1 , Symbol s2  -> Symbol.equal s1 s2
+  | Symbol _, _ | _, Symbol _ -> false
+  | Const c1, Const c2 -> compare_const c1 c2 = 0
+  | Const _, _ | _, Const _ -> false
+  | Allocated_const c1, Allocated_const c2 ->
+    Allocated_const.compare c1 c2 = 0
+  | Allocated_const _, _ | _, Allocated_const _ -> false
+  | Read_mutable mv1, Read_mutable mv2 -> Mutable_variable.equal mv1 mv2
+  | Read_mutable _, _ | _, Read_mutable _ -> false
+  | Read_symbol_field (s1, i1), Read_symbol_field (s2, i2) ->
+    Symbol.equal s1 s2 && i1 = i2
+  | Read_symbol_field _, _ | _, Read_symbol_field _ -> false
+  | Set_of_closures s1, Set_of_closures s2 -> same_set_of_closures s1 s2
+  | Set_of_closures _, _ | _, Set_of_closures _ -> false
+  | Project_closure f1, Project_closure f2 -> same_project_closure f1 f2
+  | Project_closure _, _ | _, Project_closure _ -> false
+  | Project_var v1, Project_var v2 ->
+    Variable.equal v1.closure v2.closure
+      && Closure_id.equal v1.closure_id v2.closure_id
+      && Var_within_closure.equal v1.var v2.var
+  | Project_var _, _ | _, Project_var _ -> false
+  | Move_within_set_of_closures m1, Move_within_set_of_closures m2 ->
+    same_move_within_set_of_closures m1 m2
+  | Move_within_set_of_closures _, _ | _, Move_within_set_of_closures _ ->
+    false
+  | Prim (p1, al1, _), Prim (p2, al2, _) ->
+    p1 = p2 && Misc.samelist Variable.equal al1 al2
+  | Prim _, _ | _, Prim _ -> false
+  | Expr e1, Expr e2 -> same e1 e2
+
+and sameclosure (c1 : Flambda.function_declaration)
+      (c2 : Flambda.function_declaration) =
+  Misc.samelist Variable.equal c1.params c2.params
+    && same c1.body c2.body
+
+and same_set_of_closures (c1 : Flambda.set_of_closures)
+      (c2 : Flambda.set_of_closures) =
+  Variable.Map.equal sameclosure c1.function_decls.funs c2.function_decls.funs
+    && Variable.Map.equal Variable.equal c1.free_vars c2.free_vars
+    && Variable.Map.equal Variable.equal c1.specialised_args
+        c2.specialised_args
+
+and same_project_closure (s1 : Flambda.project_closure)
+      (s2 : Flambda.project_closure) =
+  Variable.equal s1.set_of_closures s2.set_of_closures
+    && Closure_id.equal s1.closure_id s2.closure_id
+
+and same_move_within_set_of_closures (m1 : Flambda.move_within_set_of_closures)
+      (m2 : Flambda.move_within_set_of_closures) =
+  Variable.equal m1.closure m2.closure
+    && Closure_id.equal m1.start_from m2.start_from
+    && Closure_id.equal m1.move_to m2.move_to
+
+and samebinding (v1, n1) (v2, n2) =
+  Variable.equal v1 v2 && same_named n1 n2
+
+and sameswitch (fs1 : Flambda.switch) (fs2 : Flambda.switch) =
+  let samecase (n1, a1) (n2, a2) = n1 = n2 && same a1 a2 in
+  fs1.numconsts = fs2.numconsts
+    && fs1.numblocks = fs2.numblocks
+    && Misc.samelist samecase fs1.consts fs2.consts
+    && Misc.samelist samecase fs1.blocks fs2.blocks
+    && Misc.sameoption same fs1.failaction fs2.failaction
+
+let can_be_merged = same
+
+(* CR-soon mshinwell: this should use the explicit ignore functions *)
+let toplevel_substitution sb tree =
+  let sb' = sb in
+  let sb v = try Variable.Map.find v sb with Not_found -> v in
+  let aux (flam : Flambda.t) : Flambda.t =
+    match flam with
+    | Var var -> Var (sb var)
+    | Let_mutable (mut_var, var, body) ->
+      Let_mutable (mut_var, sb var, body)
+    | Assign { being_assigned; new_value; } ->
+      Assign { being_assigned; new_value = sb new_value; }
+    | Apply { func; args; kind; dbg; inline; } ->
+      Apply { func = sb func; args = List.map sb args; kind; dbg; inline; }
+    | If_then_else (cond, e1, e2) -> If_then_else (sb cond, e1, e2)
+    | Switch (cond, sw) -> Switch (sb cond, sw)
+    | String_switch (cond, branches, def) ->
+      String_switch (sb cond, branches, def)
+    | Send { kind; meth; obj; args; dbg } ->
+      Send { kind; meth = sb meth; obj = sb obj; args = List.map sb args; dbg }
+    | For { bound_var; from_value; to_value; direction; body } ->
+      For { bound_var; from_value = sb from_value; to_value = sb to_value;
+            direction; body }
+    | Static_raise (static_exn, args) ->
+      Static_raise (static_exn, List.map sb args)
+    | Static_catch _ | Try_with _ | While _
+    | Let _ | Let_rec _ | Proved_unreachable -> flam
+  in
+  let aux_named (named : Flambda.named) : Flambda.named =
+    match named with
+    | Symbol _ | Const _ | Expr _ -> named
+    | Allocated_const _ | Read_mutable _ -> named
+    | Read_symbol_field _ -> named
+    | Set_of_closures set_of_closures ->
+      let set_of_closures =
+        Flambda.create_set_of_closures
+          ~function_decls:set_of_closures.function_decls
+          ~free_vars:(Variable.Map.map sb set_of_closures.free_vars)
+          ~specialised_args:
+            (Variable.Map.map sb set_of_closures.specialised_args)
+      in
+      Set_of_closures set_of_closures
+    | Project_closure project_closure ->
+      Project_closure {
+        project_closure with
+        set_of_closures = sb project_closure.set_of_closures;
+      }
+    | Move_within_set_of_closures move_within_set_of_closures ->
+      Move_within_set_of_closures {
+        move_within_set_of_closures with
+        closure = sb move_within_set_of_closures.closure;
+      }
+    | Project_var project_var ->
+      Project_var {
+        project_var with
+        closure = sb project_var.closure;
+      }
+    | Prim (prim, args, dbg) ->
+      Prim (prim, List.map sb args, dbg)
+  in
+  if Variable.Map.is_empty sb' then tree
+  else Flambda_iterators.map_toplevel aux aux_named tree
+
+let make_closure_declaration ~id ~body ~params : Flambda.t =
+  let free_variables = Flambda.free_variables body in
+  let param_set = Variable.Set.of_list params in
+  if not (Variable.Set.subset param_set free_variables) then begin
+    Misc.fatal_error "Flambda_utils.make_closure_declaration"
+  end;
+  let sb =
+    Variable.Set.fold
+      (fun id sb -> Variable.Map.add id (Variable.rename id) sb)
+      free_variables Variable.Map.empty
+  in
+  (* CR-soon mshinwell: try to eliminate this [toplevel_substitution].  This
+     function is only called from [Inline_and_simplify], so we should be able
+     to do something similar to what happens in [Inlining_transforms] now. *)
+  let body = toplevel_substitution sb body in
+  let subst id = Variable.Map.find id sb in
+  let function_declaration =
+    Flambda.create_function_declaration ~params:(List.map subst params)
+      ~body ~stub:false ~dbg:Debuginfo.none ~inline:Default_inline
+      ~is_a_functor:false
+  in
+  assert (Variable.Set.equal (Variable.Set.map subst free_variables)
+    function_declaration.free_variables);
+  let free_vars =
+    Variable.Map.fold (fun id id' fv' ->
+        Variable.Map.add id' id fv')
+      (Variable.Map.filter (fun id _ -> not (Variable.Set.mem id param_set))
+        sb)
+      Variable.Map.empty
+  in
+  let compilation_unit = Compilation_unit.get_current_exn () in
+  let set_of_closures_var =
+    Variable.create "set_of_closures"
+      ~current_compilation_unit:compilation_unit
+  in
+  let set_of_closures =
+    let function_decls =
+      Flambda.create_function_declarations
+        ~set_of_closures_id:(Set_of_closures_id.create compilation_unit)
+        ~funs:(Variable.Map.singleton id function_declaration)
+    in
+    Flambda.create_set_of_closures ~function_decls ~free_vars
+      ~specialised_args:Variable.Map.empty
+  in
+  let project_closure : Flambda.named =
+    Project_closure {
+        set_of_closures = set_of_closures_var;
+        closure_id = Closure_id.wrap id;
+      }
+  in
+  let project_closure_var =
+    Variable.create "project_closure"
+      ~current_compilation_unit:compilation_unit
+  in
+  Flambda.create_let set_of_closures_var (Set_of_closures set_of_closures)
+    (Flambda.create_let project_closure_var project_closure
+      (Var (project_closure_var)))
+
+let bind ~bindings ~body =
+  List.fold_left (fun expr (var, var_def) ->
+      Flambda.create_let var var_def expr)
+    body bindings
+
+let name_expr (named : Flambda.named) ~name : Flambda.t =
+  let var =
+    Variable.create
+      ~current_compilation_unit:(Compilation_unit.get_current_exn ())
+      name
+  in
+  Flambda.create_let var named (Var var)
+
+let all_lifted_constants (program : Flambda.program) =
+  let rec loop (program : Flambda.program_body) =
+    match program with
+    | Let_symbol (symbol, decl, program) -> (symbol, decl) :: (loop program)
+    | Let_rec_symbol (decls, program) ->
+      List.fold_left (fun l (symbol, decl) -> (symbol, decl) :: l)
+        (loop program)
+        decls
+    | Initialize_symbol (_, _, _, program)
+    | Effect (_, program) -> loop program
+    | End _ -> []
+  in
+  loop program.program_body
+
+let all_lifted_constants_as_map program =
+  Symbol.Map.of_list (all_lifted_constants program)
+
+let initialize_symbols (program : Flambda.program) =
+  let rec loop (program : Flambda.program_body) =
+    match program with
+    | Initialize_symbol (symbol, tag, fields, program) ->
+      (symbol, tag, fields) :: (loop program)
+    | Effect (_, program)
+    | Let_symbol (_, _, program)
+    | Let_rec_symbol (_, program) -> loop program
+    | End _ -> []
+  in
+  loop program.program_body
+
+let imported_symbols (program : Flambda.program) =
+  program.imported_symbols
+
+let needed_import_symbols (program : Flambda.program) =
+  let dependencies = Flambda.free_symbols_program program in
+  let defined_symbol =
+    Symbol.Set.union
+      (Symbol.Set.of_list
+         (List.map fst (all_lifted_constants program)))
+      (Symbol.Set.of_list
+         (List.map (fun (s, _, _) -> s) (initialize_symbols program)))
+  in
+  Symbol.Set.diff dependencies defined_symbol
+
+let introduce_needed_import_symbols program : Flambda.program =
+  { program with
+    imported_symbols = needed_import_symbols program;
+  }
+
+let root_symbol (program : Flambda.program) =
+  let rec loop (program : Flambda.program_body) =
+    match program with
+    | Effect (_, program)
+    | Let_symbol (_, _, program)
+    | Let_rec_symbol (_, program)
+    | Initialize_symbol (_, _, _, program) -> loop program
+    | End root ->
+      root
+  in
+  loop program.program_body
+
+let might_raise_static_exn flam stexn =
+  try
+    Flambda_iterators.iter_on_named
+      (function
+        | Flambda.Static_raise (ex, _) when Static_exception.equal ex stexn ->
+          raise Exit
+        | _ -> ())
+      (fun _ -> ())
+      flam;
+    false
+  with Exit -> true
+
+let make_closure_map program =
+  let map = ref Closure_id.Map.empty in
+  let add_set_of_closures ~constant:_ : Flambda.set_of_closures -> unit = fun
+    { function_decls } ->
+    Variable.Map.iter (fun var _ ->
+        let closure_id = Closure_id.wrap var in
+        map := Closure_id.Map.add closure_id function_decls !map)
+      function_decls.funs
+  in
+  Flambda_iterators.iter_on_set_of_closures_of_program
+    program
+    ~f:add_set_of_closures;
+  !map
+
+let make_closure_map' input =
+  let map = ref Closure_id.Map.empty in
+  let add_set_of_closures _ (function_decls : Flambda.function_declarations) =
+    Variable.Map.iter (fun var _ ->
+        let closure_id = Closure_id.wrap var in
+        map := Closure_id.Map.add closure_id function_decls !map)
+      function_decls.funs
+  in
+  Set_of_closures_id.Map.iter add_set_of_closures input;
+  !map
+
+let all_lifted_constant_sets_of_closures program =
+  let set = ref Set_of_closures_id.Set.empty in
+  List.iter (function
+      | (_, Flambda.Set_of_closures {
+          function_decls = { set_of_closures_id } }) ->
+        set := Set_of_closures_id.Set.add set_of_closures_id !set
+      | _ -> ())
+    (all_lifted_constants program);
+  !set
+
+let all_sets_of_closures program =
+  let list = ref [] in
+  Flambda_iterators.iter_on_set_of_closures_of_program program
+    ~f:(fun ~constant:_ set_of_closures ->
+        list := set_of_closures :: !list);
+  !list
+
+let all_sets_of_closures_map program =
+  let r = ref Set_of_closures_id.Map.empty in
+  Flambda_iterators.iter_on_set_of_closures_of_program program
+    ~f:(fun ~constant:_ set_of_closures ->
+      r := Set_of_closures_id.Map.add
+          set_of_closures.function_decls.set_of_closures_id
+          set_of_closures !r);
+  !r
+
+let all_function_decls_indexed_by_set_of_closures_id program =
+  Set_of_closures_id.Map.map
+    (fun { Flambda. function_decls; _ } -> function_decls)
+    (all_sets_of_closures_map program)
+
+let all_function_decls_indexed_by_closure_id program =
+  let aux_fun function_decls fun_var _ map =
+    let closure_id = Closure_id.wrap fun_var in
+    Closure_id.Map.add closure_id function_decls map
+  in
+  let aux _ ({ function_decls; _ } : Flambda.set_of_closures) map =
+    Variable.Map.fold (aux_fun function_decls) function_decls.funs map
+  in
+  Set_of_closures_id.Map.fold aux (all_sets_of_closures_map program)
+    Closure_id.Map.empty
+
+let make_variable_symbol var =
+  Symbol.create (Compilation_unit.get_current_exn ())
+    (Linkage_name.create
+       (Variable.unique_name (Variable.rename var)))
+
+let make_variables_symbol vars =
+  let name =
+    String.concat "_and_"
+      (List.map (fun var -> Variable.unique_name (Variable.rename var)) vars)
+  in
+  Symbol.create (Compilation_unit.get_current_exn ()) (Linkage_name.create name)
+
+let substitute_read_symbol_field_for_variables
+    (substitution : (Symbol.t * int list) Variable.Map.t)
+    (expr : Flambda.t) =
+  let bind var fresh_var (expr:Flambda.t) : Flambda.t =
+    let symbol, path = Variable.Map.find var substitution in
+    let rec make_named (path:int list) : Flambda.named =
+      match path with
+      | [] -> Symbol symbol
+      | [i] -> Read_symbol_field (symbol, i)
+      | h :: t ->
+          let block = Variable.create "symbol_field_block" in
+          let field = Variable.create "get_symbol_field" in
+          Expr (
+            Flambda.create_let block (make_named t)
+              (Flambda.create_let field
+                 (Prim (Pfield h, [block], Debuginfo.none))
+                 (Var field)))
+    in
+    Flambda.create_let fresh_var (make_named path) expr
+  in
+  let substitute_named bindings (named:Flambda.named) : Flambda.named =
+    let sb to_substitute =
+      try Variable.Map.find to_substitute bindings with
+      | Not_found ->
+        to_substitute
+    in
+    match named with
+    | Symbol _ | Const _ | Expr _ -> named
+    | Allocated_const _ | Read_mutable _ -> named
+    | Read_symbol_field _ -> named
+    | Set_of_closures set_of_closures ->
+      let set_of_closures =
+        Flambda.create_set_of_closures
+          ~function_decls:set_of_closures.function_decls
+          ~free_vars:(Variable.Map.map sb set_of_closures.free_vars)
+          ~specialised_args:
+            (Variable.Map.map sb set_of_closures.specialised_args)
+      in
+      Set_of_closures set_of_closures
+    | Project_closure project_closure ->
+      Project_closure {
+        project_closure with
+        set_of_closures = sb project_closure.set_of_closures;
+      }
+    | Move_within_set_of_closures move_within_set_of_closures ->
+      Move_within_set_of_closures {
+        move_within_set_of_closures with
+        closure = sb move_within_set_of_closures.closure;
+      }
+    | Project_var project_var ->
+      Project_var {
+        project_var with
+        closure = sb project_var.closure;
+      }
+    | Prim (prim, args, dbg) ->
+      Prim (prim, List.map sb args, dbg)
+  in
+  let make_var_subst var =
+    if Variable.Map.mem var substitution then
+      let fresh = Variable.rename var in
+      fresh, (fun expr -> bind var fresh expr)
+    else
+      var, (fun x -> x)
+  in
+  let f (expr:Flambda.t) : Flambda.t =
+    match expr with
+    | Var v when Variable.Map.mem v substitution ->
+      let fresh = Variable.rename v in
+      bind v fresh (Var fresh)
+    | Var _ -> expr
+    | Let ({ var = v; defining_expr = named; _ } as let_expr) ->
+      let to_substitute =
+        Variable.Set.filter
+          (fun v -> Variable.Map.mem v substitution)
+          (Flambda.free_variables_named named)
+      in
+      if Variable.Set.is_empty to_substitute then
+        expr
+      else
+        let bindings =
+          Variable.Map.of_set (fun var -> Variable.rename var) to_substitute
+        in
+        let named =
+          substitute_named bindings named
+        in
+        let expr =
+          let module W = Flambda.With_free_variables in
+          W.create_let_reusing_body v named (W.of_body_of_let let_expr)
+        in
+        Variable.Map.fold (fun to_substitute fresh expr ->
+            bind to_substitute fresh expr)
+          bindings expr
+    | Let_mutable (mut_var, var, body) when Variable.Map.mem var substitution ->
+      let fresh = Variable.rename var in
+      bind var fresh (Let_mutable (mut_var, fresh, body))
+    | Let_mutable (_mut_var, _var, _body) ->
+      expr
+    | Let_rec (defs, body) ->
+      let free_variables_of_defs =
+        List.fold_left (fun set (_, named) ->
+            Variable.Set.union set (Flambda.free_variables_named named))
+          Variable.Set.empty defs
+      in
+      let to_substitute =
+        Variable.Set.filter
+          (fun v -> Variable.Map.mem v substitution)
+          free_variables_of_defs
+      in
+      if Variable.Set.is_empty to_substitute then
+        expr
+      else begin
+        let bindings =
+          Variable.Map.of_set (fun var -> Variable.rename var) to_substitute
+        in
+        let defs =
+          List.map (fun (var, named) ->
+              var, substitute_named bindings named)
+            defs
+        in
+        let expr =
+          Flambda.Let_rec (defs, body)
+        in
+        Variable.Map.fold (fun to_substitute fresh expr ->
+            bind to_substitute fresh expr)
+          bindings expr
+      end
+    | If_then_else (cond, ifso, ifnot) when Variable.Map.mem cond substitution ->
+      let fresh = Variable.rename cond in
+      bind cond fresh (If_then_else (fresh, ifso, ifnot))
+    | If_then_else _ ->
+      expr
+    | Switch (cond, sw) when Variable.Map.mem cond substitution ->
+      let fresh = Variable.rename cond in
+      bind cond fresh (Switch (fresh, sw))
+    | Switch _ ->
+      expr
+    | String_switch (cond, sw, def) when Variable.Map.mem cond substitution ->
+      let fresh = Variable.rename cond in
+      bind cond fresh (String_switch (fresh, sw, def))
+    | String_switch _ ->
+      expr
+    | Assign { being_assigned; new_value } when Variable.Map.mem new_value substitution ->
+      let fresh = Variable.rename new_value in
+      bind new_value fresh (Assign { being_assigned; new_value = fresh })
+    | Assign _ ->
+      expr
+    | Static_raise (exn, args) ->
+      let args, bind_args =
+        List.split (List.map make_var_subst args)
+      in
+      List.fold_right (fun f expr -> f expr) bind_args @@
+        Flambda.Static_raise (exn, args)
+    | For { bound_var; from_value; to_value; direction; body } ->
+      let from_value, bind_from_value = make_var_subst from_value in
+      let to_value, bind_to_value = make_var_subst to_value in
+      bind_from_value @@
+      bind_to_value @@
+      Flambda.For { bound_var; from_value; to_value; direction; body }
+    | Apply { func; args; kind; dbg; inline } ->
+      let func, bind_func = make_var_subst func in
+      let args, bind_args =
+        List.split (List.map make_var_subst args)
+      in
+      bind_func @@
+      List.fold_right (fun f expr -> f expr) bind_args @@
+      Flambda.Apply { func; args; kind; dbg; inline }
+    | Send { kind; meth; obj; args; dbg } ->
+      let meth, bind_meth = make_var_subst meth in
+      let obj, bind_obj = make_var_subst obj in
+      let args, bind_args =
+        List.split (List.map make_var_subst args)
+      in
+      bind_meth @@
+      bind_obj @@
+      List.fold_right (fun f expr -> f expr) bind_args @@
+      Flambda.Send { kind; meth; obj; args; dbg }
+    | Proved_unreachable
+    | While _
+    | Try_with _
+    | Static_catch _ ->
+      (* No variables directly used in those expressions *)
+      expr
+  in
+  Flambda_iterators.map_toplevel f (fun v -> v) expr
+
+(* CR-soon mshinwell: implement this so that sharing can occur in
+   matches.  Should probably leave this for the first release. *)
+type sharing_key = unit
+let make_key _ = None
+
+module Switch_storer =
+  Switch.Store
+    (struct
+      type t = Flambda.t
+      type key = sharing_key
+      let make_key = make_key
+    end)
+
+let fun_vars_referenced_in_decls
+      (function_decls : Flambda.function_declarations) ~backend =
+  let fun_vars = Variable.Map.keys function_decls.funs in
+  let symbols_to_fun_vars =
+    let module Backend = (val backend : Backend_intf.S) in
+    Variable.Set.fold (fun fun_var symbols_to_fun_vars ->
+        let closure_id = Closure_id.wrap fun_var in
+        let symbol = Backend.closure_symbol closure_id in
+        Symbol.Map.add symbol fun_var symbols_to_fun_vars)
+      fun_vars
+      Symbol.Map.empty
+  in
+  Variable.Map.map (fun (func_decl : Flambda.function_declaration) ->
+      let from_symbols =
+        Symbol.Set.fold (fun symbol fun_vars' ->
+            match Symbol.Map.find symbol symbols_to_fun_vars with
+            | exception Not_found -> fun_vars'
+            | fun_var ->
+              assert (Variable.Set.mem fun_var fun_vars);
+              Variable.Set.add fun_var fun_vars')
+          func_decl.free_symbols
+          Variable.Set.empty
+      in
+      let from_variables =
+        Variable.Set.inter func_decl.free_variables fun_vars
+      in
+      Variable.Set.union from_symbols from_variables)
+    function_decls.funs
+
+let closures_required_by_entry_point ~(entry_point : Closure_id.t) ~backend
+    (function_decls : Flambda.function_declarations) =
+  let dependencies =
+    fun_vars_referenced_in_decls function_decls ~backend
+  in
+  let set = ref Variable.Set.empty in
+  let queue = Queue.create () in
+  let add v =
+    if not (Variable.Set.mem v !set) then begin
+      set := Variable.Set.add v !set;
+      Queue.push v queue
+    end
+  in
+  add (Closure_id.unwrap entry_point);
+  while not (Queue.is_empty queue) do
+    let fun_var = Queue.pop queue in
+    match Variable.Map.find fun_var dependencies with
+    | exception Not_found -> ()
+    | fun_dependencies ->
+      Variable.Set.iter (fun dep ->
+          if Variable.Map.mem dep function_decls.funs then
+            add dep)
+        fun_dependencies
+  done;
+  !set
+
+let all_functions_parameters (function_decls : Flambda.function_declarations) =
+  Variable.Map.fold (fun _ ({ params } : Flambda.function_declaration) set ->
+      Variable.Set.union set (Variable.Set.of_list params))
+    function_decls.funs Variable.Set.empty
+
+let all_free_symbols (function_decls : Flambda.function_declarations) =
+  Variable.Map.fold (fun _ (function_decl : Flambda.function_declaration) syms ->
+      Symbol.Set.union syms function_decl.free_symbols)
+    function_decls.funs Symbol.Set.empty

middle_end/flambda_utils.mli

@@ -0,0 +1,197 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Utility functions for the Flambda intermediate language. *)
+
+(** Access functions *)
+
+(** [find_declaration f decl] raises [Not_found] if [f] is not in [decl]. *)
+val find_declaration :
+  Closure_id.t -> Flambda.function_declarations -> Flambda.function_declaration
+
+(** [find_declaration_variable f decl] raises [Not_found] if [f] is not in
+    [decl]. *)
+val find_declaration_variable :
+  Closure_id.t -> Flambda.function_declarations -> Variable.t
+
+(** [find_free_variable v clos] raises [Not_found] if [c] is not in [clos]. *)
+val find_free_variable :
+  Var_within_closure.t -> Flambda.set_of_closures -> Variable.t
+
+(** Utility functions *)
+
+val function_arity : Flambda.function_declaration -> int
+
+(** Variables "bound by a closure" are those variables free in the
+    corresponding function's body that are neither:
+    - bound as parameters of that function; nor
+    - bound by the [let] binding that introduces the function declaration(s).
+    In particular, if [f], [g] and [h] are being introduced by a
+    simultaneous, possibly mutually-recursive [let] binding then none of
+    [f], [g] or [h] are bound in any of the closures for [f], [g] and [h].
+*)
+val variables_bound_by_the_closure :
+  Closure_id.t -> Flambda.function_declarations -> Variable.Set.t
+
+(** If [can_be_merged f1 f2] is [true], it is safe to merge switch
+    branches containing [f1] and [f2]. *)
+val can_be_merged : Flambda.t -> Flambda.t -> bool
+
+val description_of_toplevel_node : Flambda.t -> string
+
+(** Sharing key, used for coalescing switch cases. *)
+type sharing_key
+val make_key : Flambda.t -> sharing_key option
+
+(* Given an expression, freshen all variables within it, and form a function
+   whose body is the resulting expression.  The variables specified by
+   [params] will become the parameters of the function; the closure will be
+   identified by [id].  [params] must only reference variables that are
+   free variables of [body]. *)
+(* CR-soon mshinwell: consider improving name and names of arguments
+   lwhite: the params restriction seems odd, perhaps give a reason
+   in the comment. *)
+val make_closure_declaration
+   : id:Variable.t
+  -> body:Flambda.t
+  -> params:Variable.t list
+  -> Flambda.t
+
+val toplevel_substitution
+   : Variable.t Variable.Map.t
+  -> Flambda.t
+  -> Flambda.t
+
+(** [bind [var1, expr1; ...; varN, exprN] body] binds using
+    [Immutable] [Let] expressions the given [(var, expr)] pairs around the
+    body. *)
+val bind
+   : bindings:(Variable.t * Flambda.named) list
+  -> body:Flambda.t
+  -> Flambda.t
+
+val name_expr : Flambda.named -> name:string -> Flambda.t
+
+val compare_const : Flambda.const -> Flambda.const -> int
+
+val initialize_symbols
+   : Flambda.program
+  -> (Symbol.t * Tag.t * Flambda.t list) list
+
+val imported_symbols : Flambda.program -> Symbol.Set.t
+
+val needed_import_symbols : Flambda.program -> Symbol.Set.t
+
+val introduce_needed_import_symbols : Flambda.program -> Flambda.program
+
+val root_symbol : Flambda.program -> Symbol.t
+
+(** Returns [true] iff the given term might raise the given static
+    exception. *)
+val might_raise_static_exn : Flambda.named -> Static_exception.t -> bool
+
+(** Creates a map from closure IDs to function declarations by iterating over
+    all sets of closures in the given program. *)
+val make_closure_map
+   : Flambda.program
+  -> Flambda.function_declarations Closure_id.Map.t
+
+(** Like [make_closure_map], but takes a mapping from set of closures IDs to
+    function declarations, instead of a [program]. *)
+val make_closure_map'
+   : Flambda.function_declarations Set_of_closures_id.Map.t
+  -> Flambda.function_declarations Closure_id.Map.t
+
+(** The definitions of all constants that have been lifted out to [Let_symbol]
+    or [Let_rec_symbol] constructions. *)
+val all_lifted_constants
+   : Flambda.program
+  -> (Symbol.t * Flambda.constant_defining_value) list
+
+(** Like [all_lifted_constant_symbols], but returns a map instead of a list. *)
+val all_lifted_constants_as_map
+   : Flambda.program
+  -> Flambda.constant_defining_value Symbol.Map.t
+
+(** The identifiers of all constant sets of closures that have been lifted out
+    to [Let_symbol] or [Let_rec_symbol] constructions. *)
+val all_lifted_constant_sets_of_closures
+   : Flambda.program
+  -> Set_of_closures_id.Set.t
+
+(** All sets of closures in the given program (whether or not bound to a
+    symbol.) *)
+val all_sets_of_closures : Flambda.program -> Flambda.set_of_closures list
+
+val all_sets_of_closures_map
+   : Flambda.program
+  -> Flambda.set_of_closures Set_of_closures_id.Map.t
+
+val all_function_decls_indexed_by_set_of_closures_id
+   : Flambda.program
+  -> Flambda.function_declarations Set_of_closures_id.Map.t
+
+val all_function_decls_indexed_by_closure_id
+   : Flambda.program
+  -> Flambda.function_declarations Closure_id.Map.t
+
+val make_variable_symbol : Variable.t -> Symbol.t
+val make_variables_symbol : Variable.t list -> Symbol.t
+
+(* CR-someday pchambart: A more general version of this function might
+   take a [named] instead of a symbol and be called with
+   [Read_symbol_field (symbol, 0)]. *)
+val substitute_read_symbol_field_for_variables
+   : (Symbol.t * int list) Variable.Map.t
+  -> Flambda.t
+  -> Flambda.t
+
+(** For the compilation of switch statements. *)
+module Switch_storer : sig
+  val mk_store : unit -> Flambda.t Switch.t_store
+end
+
+(** Within a set of function declarations there is a set of function bodies,
+    each of which may (or may not) reference one of the other functions in
+    the same set.  Initially such intra-set references are by [Var]s (known
+    as "fun_var"s) but if the function is lifted by [Lift_constants] then the
+    references will be translated to [Symbol]s.  This means that optimization
+    passes that need to identify whether a given "fun_var" (i.e. a key in the
+    [funs] map in a value of type [function_declarations]) is used in one of
+    the function bodies need to examine the [free_symbols] as well as the
+    [free_variables] members of [function_declarations].  This function makes
+    that process easier by computing all used "fun_var"s in the bodies of
+    the given set of function declarations, including the cases where the
+    references are [Symbol]s.  The returned value is a map from "fun_var"s
+    to the "fun_var"s (if any) used in the body of the function associated
+    with that "fun_var".
+*)
+val fun_vars_referenced_in_decls
+   : Flambda.function_declarations
+  -> backend:(module Backend_intf.S)
+  -> Variable.Set.t Variable.Map.t
+
+(** Computes the set of closure_id in the set of closures that are
+    required used (transitively) the entry_point *)
+val closures_required_by_entry_point
+   : entry_point:Closure_id.t
+  -> backend:(module Backend_intf.S)
+  -> Flambda.function_declarations
+  -> Variable.Set.t
+
+val all_functions_parameters : Flambda.function_declarations -> Variable.Set.t
+
+val all_free_symbols : Flambda.function_declarations -> Symbol.Set.t

middle_end/freshening.ml

@@ -0,0 +1,334 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type tbl = {
+  sb_var : Variable.t Variable.Map.t;
+  sb_mutable_var : Mutable_variable.t Mutable_variable.Map.t;
+  sb_exn : Static_exception.t Static_exception.Map.t;
+  (* Used to handle substitution sequences: we cannot call the substitution
+     recursively because there can be name clashes. *)
+  back_var : Variable.t list Variable.Map.t;
+  back_mutable_var : Mutable_variable.t list Mutable_variable.Map.t;
+}
+
+type t =
+  | Inactive
+  | Active of tbl
+
+type subst = t
+
+let empty_tbl = {
+  sb_var = Variable.Map.empty;
+  sb_mutable_var = Mutable_variable.Map.empty;
+  sb_exn = Static_exception.Map.empty;
+  back_var = Variable.Map.empty;
+  back_mutable_var = Mutable_variable.Map.empty;
+}
+
+let print ppf = function
+  | Inactive -> Format.fprintf ppf "Inactive"
+  | Active tbl ->
+    Format.fprintf ppf "Active:@ ";
+    Variable.Map.iter (fun var1 var2 ->
+        Format.fprintf ppf "%a -> %a@ "
+          Variable.print var1
+          Variable.print var2)
+      tbl.sb_var;
+    Mutable_variable.Map.iter (fun mut_var1 mut_var2 ->
+        Format.fprintf ppf "(mutable) %a -> %a@ "
+          Mutable_variable.print mut_var1
+          Mutable_variable.print mut_var2)
+      tbl.sb_mutable_var;
+    Variable.Map.iter (fun var vars ->
+        Format.fprintf ppf "%a -> %a@ "
+          Variable.print var
+          Variable.Set.print (Variable.Set.of_list vars))
+      tbl.back_var;
+    Mutable_variable.Map.iter (fun mut_var mut_vars ->
+        Format.fprintf ppf "(mutable) %a -> %a@ "
+          Mutable_variable.print mut_var
+          Mutable_variable.Set.print (Mutable_variable.Set.of_list mut_vars))
+      tbl.back_mutable_var
+
+let empty = Inactive
+
+let empty_preserving_activation_state = function
+  | Inactive -> Inactive
+  | Active _ -> Active empty_tbl
+
+let activate = function
+  | Inactive -> Active empty_tbl
+  | Active _ as t -> t
+
+let rec add_sb_var sb id id' =
+  let sb = { sb with sb_var = Variable.Map.add id id' sb.sb_var } in
+  let sb =
+    try let pre_vars = Variable.Map.find id sb.back_var in
+      List.fold_left (fun sb pre_id -> add_sb_var sb pre_id id') sb pre_vars
+    with Not_found -> sb in
+  let back_var =
+    let l = try Variable.Map.find id' sb.back_var with Not_found -> [] in
+    Variable.Map.add id' (id :: l) sb.back_var in
+  { sb with back_var }
+
+let rec add_sb_mutable_var sb id id' =
+  let sb = { sb with sb_mutable_var = Mutable_variable.Map.add id id' sb.sb_mutable_var } in
+  let sb =
+    try let pre_vars = Mutable_variable.Map.find id sb.back_mutable_var in
+      List.fold_left (fun sb pre_id -> add_sb_mutable_var sb pre_id id') sb pre_vars
+    with Not_found -> sb in
+  let back_mutable_var =
+    let l = try Mutable_variable.Map.find id' sb.back_mutable_var with Not_found -> [] in
+    Mutable_variable.Map.add id' (id :: l) sb.back_mutable_var in
+  { sb with back_mutable_var }
+
+let apply_static_exception t i =
+  match t with
+  | Inactive ->
+    i
+  | Active t ->
+    try Static_exception.Map.find i t.sb_exn
+    with Not_found -> i
+
+let add_static_exception t i =
+  match t with
+  | Inactive -> i, t
+  | Active t ->
+    let i' = Static_exception.create () in
+    let sb_exn =
+      Static_exception.Map.add i i' t.sb_exn
+    in
+    i', Active { t with sb_exn; }
+
+let active_add_variable t id =
+  let id' = Variable.rename id in
+  let t = add_sb_var t id id' in
+  id', t
+
+let add_variable t id =
+  match t with
+  | Inactive -> id, t
+  | Active t ->
+     let id', t = active_add_variable t id in
+     id', Active t
+
+let active_add_variables' t ids =
+  List.fold_right (fun id (ids, t) ->
+      let id', t = active_add_variable t id in
+      id' :: ids, t) ids ([], t)
+
+let add_variables t defs =
+  List.fold_right (fun (id, data) (defs, t) ->
+      let id', t = add_variable t id in
+      (id', data) :: defs, t) defs ([], t)
+
+let add_variables' t ids =
+  List.fold_right (fun id (ids, t) ->
+      let id', t = add_variable t id in
+      id' :: ids, t) ids ([], t)
+
+let active_add_mutable_variable t id =
+  let id' = Mutable_variable.freshen id in
+  let t = add_sb_mutable_var t id id' in
+  id', t
+
+let add_mutable_variable t id =
+  match t with
+  | Inactive -> id, t
+  | Active t ->
+     let id', t = active_add_mutable_variable t id in
+     id', Active t
+
+let active_find_var_exn t id =
+  try Variable.Map.find id t.sb_var with
+  | Not_found ->
+      Misc.fatal_error (Format.asprintf "find_var: can't find %a@."
+          Variable.print id)
+
+let apply_variable t var =
+  match t with
+  | Inactive -> var
+  | Active t ->
+   try Variable.Map.find var t.sb_var with
+   | Not_found -> var
+
+let apply_mutable_variable t mut_var =
+  match t with
+  | Inactive -> mut_var
+  | Active t ->
+   try Mutable_variable.Map.find mut_var t.sb_mutable_var with
+   | Not_found -> mut_var
+
+let rewrite_recursive_calls_with_symbols t
+      (function_declarations : Flambda.function_declarations)
+      ~make_closure_symbol =
+  match t with
+  | Inactive -> function_declarations
+  | Active _ ->
+    let all_free_symbols =
+      Flambda_utils.all_free_symbols function_declarations
+    in
+    let closure_symbols_used = ref false in
+    let closure_symbols =
+      Variable.Map.fold (fun var _ map ->
+        let closure_id = Closure_id.wrap var in
+        let sym = make_closure_symbol closure_id in
+        if Symbol.Set.mem sym all_free_symbols then begin
+          closure_symbols_used := true;
+          Symbol.Map.add sym var map
+        end else begin
+          map
+        end)
+      function_declarations.funs Symbol.Map.empty
+    in
+    if not !closure_symbols_used then begin
+      (* Don't waste time rewriting the function declaration(s) if there
+         are no occurrences of any of the closure symbols. *)
+      function_declarations
+    end else begin
+      let funs =
+        Variable.Map.map (fun (ffun : Flambda.function_declaration) ->
+          let body =
+            Flambda_iterators.map_toplevel_named
+              (* CR-someday pchambart: This may be worth deep substituting
+                 below the closures, but that means that we need to take care
+                 of functions' free variables. *)
+              (function
+                | Symbol sym when Symbol.Map.mem sym closure_symbols ->
+                  Expr (Var (Symbol.Map.find sym closure_symbols))
+                | e -> e)
+              ffun.body
+          in
+          Flambda.create_function_declaration ~params:ffun.params
+            ~body ~stub:ffun.stub ~dbg:ffun.dbg ~inline:ffun.inline
+            ~is_a_functor:ffun.is_a_functor)
+          function_declarations.funs
+      in
+      Flambda.update_function_declarations function_declarations ~funs
+    end
+
+module Project_var = struct
+  type t =
+    { vars_within_closure : Var_within_closure.t Var_within_closure.Map.t;
+      closure_id : Closure_id.t Closure_id.Map.t }
+
+  let empty =
+    { vars_within_closure = Var_within_closure.Map.empty;
+      closure_id = Closure_id.Map.empty;
+    }
+
+  let new_subst_fv t id subst =
+    match subst with
+    | Inactive -> id, subst, t
+    | Active subst ->
+      let id' = Variable.rename id in
+      let subst = add_sb_var subst id id' in
+      let off = Var_within_closure.wrap id in
+      let off' = Var_within_closure.wrap id' in
+      let off_sb = Var_within_closure.Map.add off off' t.vars_within_closure in
+      id', Active subst, { t with vars_within_closure = off_sb; }
+
+  let new_subst_fun t id subst =
+    let id' = Variable.rename id in
+    let subst = add_sb_var subst id id' in
+    let off = Closure_id.wrap id in
+    let off' = Closure_id.wrap id' in
+    let off_sb = Closure_id.Map.add off off' t.closure_id in
+    id', subst, { t with closure_id = off_sb; }
+
+  (** Returns :
+      * The map of new_identifiers -> expression
+      * The new environment with added substitution
+      * a fresh ffunction_subst with only the substitution of free variables
+   *)
+  let subst_free_vars fv subst =
+    Variable.Map.fold (fun id lam (fv, subst, t) ->
+        let id, subst, t = new_subst_fv t id subst in
+        Variable.Map.add id lam fv, subst, t)
+      fv (Variable.Map.empty, subst, empty)
+
+  (** Returns :
+      * The function_declaration with renamed function identifiers
+      * The new environment with added substitution
+      * The ffunction_subst completed with function substitution
+
+      subst_free_vars must have been used to build off_sb
+   *)
+  let func_decls_subst t (subst : subst)
+        (func_decls : Flambda.function_declarations) =
+    match subst with
+    | Inactive -> func_decls, subst, t
+    | Active subst ->
+      let subst_func_decl _fun_id (func_decl : Flambda.function_declaration)
+            subst =
+        let params, subst = active_add_variables' subst func_decl.params in
+        (* It is not a problem to share the substitution of parameter
+           names between function: There should be no clash *)
+        (* CR mshinwell: could this violate one of the new invariants in
+           Flambda_invariants (about all parameters being distinct within one
+           set of function declarations)? *)
+        let body =
+          Flambda_utils.toplevel_substitution subst.sb_var func_decl.body
+        in
+        let function_decl =
+          Flambda.create_function_declaration ~params
+            ~body ~stub:func_decl.stub ~dbg:func_decl.dbg
+            ~inline:func_decl.inline ~is_a_functor:func_decl.is_a_functor
+        in
+        function_decl, subst
+      in
+      let subst, t =
+        Variable.Map.fold (fun orig_id _func_decl (subst, t) ->
+            let _id, subst, t = new_subst_fun t orig_id subst in
+            subst, t)
+          func_decls.funs (subst,t) in
+      let funs, subst =
+        Variable.Map.fold (fun orig_id func_decl (funs, subst) ->
+            let func_decl, subst = subst_func_decl orig_id func_decl subst in
+            let id = active_find_var_exn subst orig_id in
+            let funs = Variable.Map.add id func_decl funs in
+            funs, subst)
+          func_decls.funs (Variable.Map.empty, subst) in
+      let current_unit = Compilation_unit.get_current_exn () in
+      let function_decls =
+        Flambda.create_function_declarations
+          ~set_of_closures_id:(Set_of_closures_id.create current_unit)
+          ~funs
+      in
+      function_decls, Active subst, t
+
+  let apply_closure_id t closure_id =
+    try Closure_id.Map.find closure_id t.closure_id
+    with Not_found -> closure_id
+
+  let apply_var_within_closure t var_in_closure =
+    try Var_within_closure.Map.find var_in_closure t.vars_within_closure
+    with Not_found -> var_in_closure
+end
+
+let apply_function_decls_and_free_vars t fv func_decls =
+  let module I = Project_var in
+  let fv, t, of_closures = I.subst_free_vars fv t in
+  let func_decls, t, of_closures =
+    I.func_decls_subst of_closures t func_decls
+  in
+  fv, func_decls, t, of_closures
+
+let does_not_freshen t vars =
+  match t with
+  | Inactive -> true
+  | Active subst ->
+    not (List.exists (fun var -> Variable.Map.mem var subst.sb_var) vars)

middle_end/freshening.mli

@@ -0,0 +1,136 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Freshening of various identifiers. *)
+
+(** A table used for freshening variables and static exception identifiers. *)
+type t
+type subst = t
+
+(** The freshening that does nothing.  This is the unique inactive
+    freshening. *)
+val empty : t
+
+(** Activate the freshening.  Without activation, operations to request
+    freshenings have no effect (cf. the documentation below for
+    [add_variable]).  As such, the inactive renaming is unique. *)
+val activate : t -> t
+
+(** Given the inactive freshening, return the same; otherwise, return an
+    empty active freshening. *)
+val empty_preserving_activation_state : t -> t
+
+(** [add_variable t var]
+    If [t] is active:
+      It returns a fresh variable [new_var] and adds [var] -> [new_var]
+      to the freshening.
+      If a renaming [other_var] -> [var] or [symbol] -> [var] was already
+      present in [t], it will also add [other_var] -> [new_var] and
+      [symbol] -> [new_var].
+    If [t] is inactive, this is the identity.
+*)
+val add_variable : t -> Variable.t -> Variable.t * t
+
+(** Like [add_variable], but for multiple variables, each freshened
+    separately. *)
+val add_variables'
+   : t
+  -> Variable.t list
+  -> Variable.t list * t
+
+(** Like [add_variables'], but passes through the second component of the
+    input list unchanged. *)
+val add_variables
+   : t
+  -> (Variable.t * 'a) list
+  -> (Variable.t * 'a) list * t
+
+(** Like [add_variable], but for mutable variables. *)
+val add_mutable_variable : t -> Mutable_variable.t -> Mutable_variable.t * t
+
+(** As for [add_variable], but for static exception identifiers. *)
+val add_static_exception : t -> Static_exception.t -> Static_exception.t * t
+
+(** [apply_variable t var] applies the freshening [t] to [var].
+    If no renaming is specified in [t] for [var] it is returned unchanged. *)
+val apply_variable : t -> Variable.t -> Variable.t
+
+(** As for [apply_variable], but for mutable variables. *)
+val apply_mutable_variable : t -> Mutable_variable.t -> Mutable_variable.t
+
+(** As for [apply_variable], but for static exception identifiers. *)
+val apply_static_exception : t -> Static_exception.t -> Static_exception.t
+
+(** Replace recursive accesses to the closures in the set through
+    [Symbol] by the corresponding [Var]. This is used to recover
+    the recursive call when importing code from another compilation unit.
+
+    If the renaming is inactive, this is the identity.
+*)
+val rewrite_recursive_calls_with_symbols
+   : t
+  -> Flambda.function_declarations
+  -> make_closure_symbol:(Closure_id.t -> Symbol.t)
+  -> Flambda.function_declarations
+
+(* CR-soon mshinwell for mshinwell: maybe inaccurate module name, it freshens
+   closure IDs as well.  Check use points though *)
+module Project_var : sig
+  (** A table used for freshening of identifiers in [Project_closure] and
+      [Move_within_set_of_closures] ("ids of closures"); and [Project_var]
+      ("bound vars of closures") expressions.
+
+      This information is propagated bottom up and populated when inlining a
+      function containing a closure declaration.
+
+      For instance,
+        [let f x =
+           let g y = ... x ... in
+           ... g.x ...           (Project_var x)
+           ... g 1 ...           (Apply (Project_closure g ...))
+           ]
+
+      If f is inlined, g is renamed. The approximation of g will carry this
+      table such that later the access to the field x of g and selection of
+      g in the closure can be substituted.
+   *)
+  type t
+
+  (* The freshening that does nothing. *)
+  val empty : t
+
+  (** Freshen a closure ID based on the given renaming.  The same ID is
+     returned if the renaming does not affect it. *)
+  val apply_closure_id : t -> Closure_id.t -> Closure_id.t
+
+  (** Like [apply_closure_id], but for variables within closures. *)
+  val apply_var_within_closure
+     : t
+    -> Var_within_closure.t
+    -> Var_within_closure.t
+end
+
+(* CR-soon mshinwell for mshinwell: add comment *)
+val apply_function_decls_and_free_vars
+   : t
+  -> 'a Variable.Map.t
+  -> Flambda.function_declarations
+  -> 'a Variable.Map.t * Flambda.function_declarations * t
+    * Project_var.t
+
+val does_not_freshen : t -> Variable.t list -> bool
+
+val print : Format.formatter -> t -> unit

middle_end/inconstant_idents.ml

@@ -0,0 +1,469 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* This cannot be done in a single simple pass due to expressions like:
+
+  let rec ... =
+    ...
+    let rec f1 x =
+      let f2 y =
+        f1 rec_list
+      in
+      f2 v
+    and rec_list = f1 :: rec_list in
+    ...
+
+  and v = ...
+
+  f1, f2 and rec_list are constants iff v is a constant.
+
+  To handle this we populate both a 'not constant' set NC and a set of
+  implications between variables.
+
+  For example, the above code would generate the implications:
+
+      f1 in NC => rec_list in NC
+      f2 in NC => f1 in NC
+      rec_list in NC => f2 in NC
+      v in NC => f1 in NC
+
+   then if v is found to be in NC this will be propagated to place
+   f1, f2 and rec_list in NC as well.
+
+*)
+
+(* CR-someday lwhite: I think this pass could be combined with
+   alias_analysis and other parts of lift_constants into a single
+   type-based anaylsis which infers a "type" for each variable that is
+   either an allocated_constant expression or "not constant".  Recursion
+   would be handled with unification variables. *)
+
+module Int = Numbers.Int
+module Symbol_field = struct
+  type t = Symbol.t * Int.t
+  include Identifiable.Make (Identifiable.Pair (Symbol) (Int))
+end
+
+type dep =
+  | Closure of Set_of_closures_id.t
+  | Var of Variable.t
+  | Symbol of Symbol.t
+  | Symbol_field of Symbol_field.t
+
+type state =
+  | Not_constant
+  | Implication of dep list
+
+type result = {
+  id : state Variable.Tbl.t;
+  closure : state Set_of_closures_id.Tbl.t;
+}
+
+module type Param = sig
+  val program : Flambda.program
+  val compilation_unit : Compilation_unit.t
+end
+
+(* CR-soon mshinwell: consider removing functor *)
+module Inconstants (P:Param) (Backend:Backend_intf.S) = struct
+  let program = P.program
+  let compilation_unit = P.compilation_unit
+  let imported_symbols = Flambda_utils.imported_symbols program
+
+  (* Sets representing NC *)
+  let variables : state Variable.Tbl.t = Variable.Tbl.create 42
+  let closures : state Set_of_closures_id.Tbl.t =
+    Set_of_closures_id.Tbl.create 42
+  let symbols : state Symbol.Tbl.t = Symbol.Tbl.create 42
+  let symbol_fields : state Symbol_field.Tbl.t = Symbol_field.Tbl.create 42
+
+  let mark_queue = Queue.create ()
+
+  (* CR-soon pchambart: We could probably improve that quite a lot by adding
+     (the future annotation) [@unrolled] at the right call sites.  Or more
+     directly mark mark_dep as [@inline] and call it instead of mark_curr in
+     some situations.
+  *)
+
+  (* adds 'dep in NC' *)
+  let rec mark_dep = function
+    | Var id -> begin
+      match Variable.Tbl.find variables id with
+      | Not_constant -> ()
+      | Implication deps ->
+        Variable.Tbl.replace variables id Not_constant;
+        Queue.push deps mark_queue
+      | exception Not_found ->
+        Variable.Tbl.add variables id Not_constant
+      end
+    | Closure cl -> begin
+      match Set_of_closures_id.Tbl.find closures cl with
+      | Not_constant -> ()
+      | Implication deps ->
+        Set_of_closures_id.Tbl.replace closures cl Not_constant;
+        Queue.push deps mark_queue
+      | exception Not_found ->
+        Set_of_closures_id.Tbl.add closures cl Not_constant
+      end
+    | Symbol s -> begin
+      match Symbol.Tbl.find symbols s with
+      | Not_constant -> ()
+      | Implication deps ->
+        Symbol.Tbl.replace symbols s Not_constant;
+        Queue.push deps mark_queue
+      | exception Not_found ->
+        Symbol.Tbl.add symbols s Not_constant
+      end
+    | Symbol_field s -> begin
+      match Symbol_field.Tbl.find symbol_fields s with
+      | Not_constant -> ()
+      | Implication deps ->
+        Symbol_field.Tbl.replace symbol_fields s Not_constant;
+        Queue.push deps mark_queue
+      | exception Not_found ->
+        Symbol_field.Tbl.add symbol_fields s Not_constant
+      end
+
+  and mark_deps deps =
+    List.iter mark_dep deps
+
+  and complete_marking () =
+    while not (Queue.is_empty mark_queue) do
+      let deps =
+        try
+          Queue.take mark_queue
+        with Not_found -> []
+      in
+      mark_deps deps;
+    done
+
+  (* adds 'curr in NC' *)
+  let mark_curr curr =
+    mark_deps curr;
+    complete_marking ()
+
+  (* adds in the tables 'dep in NC => curr in NC' *)
+  let register_implication ~in_nc:dep ~implies_in_nc:curr =
+    match dep with
+    | Var id -> begin
+      match Variable.Tbl.find variables id with
+      | Not_constant ->
+        mark_deps curr;
+        complete_marking ();
+      | Implication deps ->
+        let deps = List.rev_append curr deps in
+        Variable.Tbl.replace variables id (Implication deps)
+      | exception Not_found ->
+        Variable.Tbl.add variables id (Implication curr);
+      end
+    | Closure cl -> begin
+      match Set_of_closures_id.Tbl.find closures cl with
+      | Not_constant ->
+        mark_deps curr;
+        complete_marking ();
+      | Implication deps ->
+        let deps = List.rev_append curr deps in
+        Set_of_closures_id.Tbl.replace closures cl (Implication deps)
+      | exception Not_found ->
+        Set_of_closures_id.Tbl.add closures cl (Implication curr);
+      end
+    | Symbol symbol -> begin
+      match Symbol.Tbl.find symbols symbol with
+      | Not_constant ->
+        mark_deps curr;
+        complete_marking ();
+      | Implication deps ->
+        let deps = List.rev_append curr deps in
+        Symbol.Tbl.replace symbols symbol (Implication deps)
+      | exception Not_found ->
+        Symbol.Tbl.add symbols symbol (Implication curr);
+      end
+    | Symbol_field ((symbol, _) as field) -> begin
+      match Symbol_field.Tbl.find symbol_fields field with
+      | Not_constant ->
+        mark_deps curr;
+        complete_marking ();
+      | Implication deps ->
+        let deps = List.rev_append curr deps in
+        Symbol_field.Tbl.replace symbol_fields field (Implication deps)
+      | exception Not_found ->
+        (* There is no information available about the contents of imported
+           symbols, so we must consider all their fields as inconstant. *)
+        (* CR-someday pchambart: recover that from the cmx information *)
+        if Symbol.Set.mem symbol imported_symbols then begin
+          Symbol_field.Tbl.add symbol_fields field Not_constant;
+          mark_deps curr;
+          complete_marking ();
+        end else begin
+          Symbol_field.Tbl.add symbol_fields field (Implication curr)
+        end
+      end
+
+  (* First loop: iterates on the tree to mark dependencies.
+
+     curr is the variables or closures to wich we add constraints like
+     '... in NC => curr in NC' or 'curr in NC'
+
+     It can be empty when no constraint can be added like in the toplevel
+     expression or in the body of a function.
+  *)
+  let rec mark_loop ~toplevel (curr : dep list) (flam : Flambda.t) =
+    match flam with
+    | Let { var; defining_expr = lam; body; _ } ->
+      mark_named ~toplevel [Var var] lam;
+      (* adds 'var in NC => curr in NC'
+         This is not really necessary, but compiling this correctly is
+         trickier than eliminating that earlier. *)
+      mark_var var curr;
+      mark_loop ~toplevel curr body
+    | Let_mutable (_mut_var, var, body) ->
+      mark_var var curr;
+      mark_loop ~toplevel curr body
+    | Let_rec(defs, body) ->
+      List.iter (fun (var, def) ->
+          mark_named ~toplevel [Var var] def;
+          (* adds 'var in NC => curr in NC' same remark as let case *)
+          mark_var var curr)
+        defs;
+      mark_loop ~toplevel curr body
+    | Var var -> mark_var var curr
+    (* Not constant cases: we mark directly 'curr in NC' and mark
+       bound variables as in NC also *)
+    | Assign _ ->
+      mark_curr curr
+    | Try_with (f1,id,f2) ->
+      mark_curr [Var id];
+      mark_curr curr;
+      mark_loop ~toplevel [] f1;
+      mark_loop ~toplevel [] f2
+    | Static_catch (_,ids,f1,f2) ->
+      List.iter (fun id -> mark_curr [Var id]) ids;
+      mark_curr curr;
+      mark_loop ~toplevel [] f1;
+      mark_loop ~toplevel [] f2
+      (* CR-someday pchambart: If recursive staticcatch is introduced:
+         this becomes ~toplevel:false *)
+    | For { bound_var; from_value; to_value; direction = _; body; } ->
+      mark_curr [Var bound_var];
+      mark_var from_value curr;
+      mark_var to_value curr;
+      mark_curr curr;
+      mark_loop ~toplevel:false [] body
+    | While (f1,body) ->
+      mark_curr curr;
+      mark_loop ~toplevel [] f1;
+      mark_loop ~toplevel:false [] body
+    | If_then_else (f1,f2,f3) ->
+      mark_curr curr;
+      mark_curr [Var f1];
+      mark_loop ~toplevel [] f2;
+      mark_loop ~toplevel [] f3
+    | Static_raise (_,l) ->
+      mark_curr curr;
+      List.iter (fun v -> mark_var v curr) l
+    | Apply ({func; args; _ }) ->
+      mark_curr curr;
+      mark_var func curr;
+      mark_vars args curr;
+    | Switch (arg,sw) ->
+      mark_curr curr;
+      mark_var arg curr;
+      List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw.consts;
+      List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw.blocks;
+      Misc.may (fun l -> mark_loop ~toplevel [] l) sw.failaction
+    | String_switch (arg,sw,def) ->
+      mark_curr curr;
+      mark_var arg curr;
+      List.iter (fun (_,l) -> mark_loop ~toplevel [] l) sw;
+      Misc.may (fun l -> mark_loop ~toplevel [] l) def
+    | Send { kind = _; meth; obj; args; dbg = _; } ->
+      mark_var meth curr;
+      mark_var obj curr;
+      List.iter (fun arg -> mark_var arg curr) args
+    | Proved_unreachable ->
+      mark_curr curr
+
+  and mark_named ~toplevel curr (named : Flambda.named) =
+    match named with
+    | Set_of_closures (set_of_closures) ->
+      mark_loop_set_of_closures ~toplevel curr set_of_closures
+    | Const _ | Allocated_const _ -> ()
+    | Read_mutable _ -> mark_curr curr
+    | Symbol symbol -> begin
+        let current_unit = Compilation_unit.get_current_exn () in
+        if Compilation_unit.equal current_unit (Symbol.compilation_unit symbol)
+        then
+          ()
+        else
+          match (Backend.import_symbol symbol).descr with
+          | Value_unresolved _ ->
+            (* Constant when 'for_clambda' means: can be a symbol (which is
+               obviously the case here) with a known approximation.  If this
+               condition is not satisfied we mark as inconstant to reflect
+               the fact that the symbol's contents are unknown and thus
+               prevent attempts to examine it.  (This is a bit of a hack.) *)
+            mark_curr curr
+          | _ ->
+            ()
+      end
+    | Read_symbol_field (symbol, index) ->
+      register_implication ~in_nc:(Symbol_field (symbol, index)) ~implies_in_nc:curr
+    (* Globals are symbols: handle like symbols *)
+    | Prim (Lambda.Pgetglobal _id, [], _) -> ()
+    (* Constant constructors: those expressions are constant if all their parameters are:
+       - makeblock is compiled to a constant block
+       - offset is compiled to a pointer inside a constant closure.
+         See Cmmgen for the details
+
+       makeblock(Mutable) can be a 'constant' if it is allocated at toplevel: if this
+       expression is evaluated only once.
+    *)
+    | Prim (Lambda.Pmakeblock (_tag, Asttypes.Immutable), args, _dbg) ->
+      mark_vars args curr
+(*  (* CR-someday pchambart: If global mutables are allowed: *)
+    | Prim(Lambda.Pmakeblock(_tag, Asttypes.Mutable), args, _dbg, _)
+      when toplevel ->
+      List.iter (mark_loop ~toplevel curr) args
+*)
+    | Prim (Pmakearray (Pfloatarray, Immutable), args, _) ->
+      mark_vars args curr
+    | Prim (Pmakearray (Pfloatarray, Mutable), args, _) ->
+      if toplevel then mark_vars args curr
+      else mark_curr curr
+    | Prim (Pduparray (Pfloatarray, Immutable), [arg], _) ->
+      mark_var arg curr
+    | Prim (Pduparray (Pfloatarray, Mutable), [arg], _) ->
+      if toplevel then mark_var arg curr
+      else mark_curr curr
+    | Prim (Pduparray _, _, _) ->
+      Misc.fatal_errorf
+        "Unsupported case of Pduparray in Inconstant_idents: %a"
+        Flambda.print_named named
+    | Project_closure ({ set_of_closures; closure_id; }) ->
+      if Closure_id.in_compilation_unit closure_id compilation_unit then
+        mark_var set_of_closures curr
+      else
+        mark_curr curr
+    | Move_within_set_of_closures
+        ({ closure; start_from = _; move_to = _ }) ->
+      mark_var closure curr
+    | Project_var ({ closure; closure_id = _; var = _ }) ->
+      mark_var closure curr
+    | Prim (Lambda.Pfield _, [f1], _) ->
+      mark_curr curr;
+      mark_var f1 curr
+    | Prim (_, args, _) ->
+      mark_curr curr;
+      mark_vars args curr
+    | Expr flam ->
+      mark_loop ~toplevel curr flam
+
+  and mark_var var curr =
+    (* adds 'id in NC => curr in NC' *)
+    register_implication ~in_nc:(Var var) ~implies_in_nc:curr
+
+  and mark_vars vars curr =
+    (* adds 'id in NC => curr in NC' *)
+    List.iter (fun var -> mark_var var curr) vars
+
+  (* [toplevel] is intended for allowing static allocations of mutable
+     blocks.  This feature should be available in a future release once the
+     necessary GC changes have been merged. (See GPR#178.) *)
+  and mark_loop_set_of_closures ~toplevel:_ curr
+        { Flambda. function_decls; free_vars; specialised_args } =
+    (* If a function in the set of closures is specialised, do not consider
+       it constant. *)
+    (* CR mshinwell for pchambart: This needs more explanation. *)
+    Variable.Map.iter (fun _ id ->
+          register_implication
+            ~in_nc:(Var id)
+            ~implies_in_nc:[Closure function_decls.set_of_closures_id])
+        specialised_args;
+    (* adds 'function_decls in NC => curr in NC' *)
+    register_implication ~in_nc:(Closure function_decls.set_of_closures_id)
+      ~implies_in_nc:curr;
+    (* a closure is constant if its free variables are constants. *)
+    Variable.Map.iter (fun inner_id var ->
+        register_implication ~in_nc:(Var var)
+          ~implies_in_nc:[Var inner_id; Closure function_decls.set_of_closures_id])
+      free_vars;
+    Variable.Map.iter (fun fun_id (ffunc : Flambda.function_declaration) ->
+        (* for each function f in a closure c 'c in NC => f' *)
+        register_implication ~in_nc:(Closure function_decls.set_of_closures_id)
+          ~implies_in_nc:[Var fun_id];
+        (* function parameters are in NC *)
+        List.iter (fun id -> mark_curr [Var id]) ffunc.params;
+        mark_loop ~toplevel:false [] ffunc.body)
+      function_decls.funs
+
+  let mark_constant_defining_value (const:Flambda.constant_defining_value) =
+    match const with
+    | Allocated_const _
+    | Block _
+    | Project_closure _ -> ()
+    | Set_of_closures set_of_closure ->
+      mark_loop_set_of_closures ~toplevel:true [] set_of_closure
+
+  let mark_program (program : Flambda.program) =
+    let rec loop (program : Flambda.program_body) =
+      match program with
+      | End _ -> ()
+      | Initialize_symbol (symbol,_tag,fields,program) ->
+        List.iteri (fun i field ->
+            mark_loop ~toplevel:true
+              [Symbol symbol; Symbol_field (symbol,i)] field)
+          fields;
+        loop program
+      | Effect (expr, program) ->
+        mark_loop ~toplevel:true [] expr;
+        loop program
+      | Let_symbol (_, def, program) ->
+        mark_constant_defining_value def;
+        loop program
+      | Let_rec_symbol (defs, program) ->
+        List.iter (fun (_, def) -> mark_constant_defining_value def) defs;
+        loop program
+    in
+    loop program.program_body
+
+  let res =
+    mark_program program;
+    { id = variables;
+      closure = closures;
+    }
+end
+
+let inconstants_on_program ~compilation_unit ~backend
+    (program : Flambda.program) =
+  let module P = struct
+    let program = program
+    let compilation_unit = compilation_unit
+  end in
+  let module Backend = (val backend : Backend_intf.S) in
+  let module I = Inconstants (P) (Backend) in
+  I.res
+
+let variable var { id; _ } =
+  match Variable.Tbl.find id var with
+  | Not_constant -> true
+  | Implication _ -> false
+  | exception Not_found -> false
+
+let closure cl { closure; _ } =
+  match Set_of_closures_id.Tbl.find closure cl with
+  | Not_constant -> true
+  | Implication _ -> false
+  | exception Not_found -> false

middle_end/inconstant_idents.mli

@@ -0,0 +1,34 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type result
+
+(** [inconstants_on_program] finds those variables and set-of-closures identifiers that
+    cannot be compiled to constants by [Flambda_to_clambda].
+*)
+val inconstants_on_program
+   : compilation_unit:Compilation_unit.t
+  -> backend:(module Backend_intf.S)
+  -> Flambda.program
+  -> result
+
+(** [variable var res] returns [true] if [var] is marked as inconstant
+    in [res]. *)
+val variable : Variable.t -> result -> bool
+
+(** [closure cl res] returns [true] if [cl] is marked as inconstant
+    in [res]. *)
+val closure : Set_of_closures_id.t -> result -> bool

middle_end/initialize_symbol_to_let_symbol.ml

@@ -0,0 +1,52 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+let constant_field (expr:Flambda.t)
+  : Flambda.constant_defining_value_block_field option =
+  match expr with
+  | Let { var; defining_expr = Const c; body = Var var' ; _ } ->
+    assert(Variable.equal var var');
+    (* This must be true since var is the only variable in scope *)
+    Some (Flambda.Const c)
+  | Let { var; defining_expr = Symbol s; body = Var var' ; _ } ->
+    assert(Variable.equal var var');
+    Some (Flambda.Symbol s)
+  | _ ->
+    None
+
+let rec loop (program : Flambda.program_body) : Flambda.program_body =
+  match program with
+  | Initialize_symbol (symbol, tag, fields, program) ->
+    let constant_fields = List.map constant_field fields in
+    begin match Misc.some_if_all_elements_are_some constant_fields with
+    | None ->
+      Initialize_symbol (symbol, tag, fields, loop program)
+    | Some fields ->
+      Let_symbol (symbol, Block (tag, fields), loop program)
+    end
+  | Let_symbol (symbol, const, program) ->
+    Let_symbol (symbol, const, loop program)
+  | Let_rec_symbol (defs, program) ->
+    Let_rec_symbol (defs, loop program)
+  | Effect (expr, program) ->
+    Effect (expr, loop program)
+  | End symbol ->
+    End symbol
+
+let run (program : Flambda.program) =
+  { program with
+    program_body = loop program.program_body;
+  }

middle_end/initialize_symbol_to_let_symbol.mli

@@ -0,0 +1,19 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Transform Initialize_symbol with only constant fields to
+    let_symbol construction. *)
+val run : Flambda.program -> Flambda.program

middle_end/inline_and_simplify.mli

@@ -0,0 +1,29 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Simplification of Flambda programs combined with function inlining:
+    for the most part a beta-reduction pass.
+
+    Readers interested in the inlining strategy should read the
+    [Inlining_decision] module first.
+*)
+val run
+   : never_inline:bool
+  -> backend:(module Backend_intf.S)
+  -> prefixname:string
+  -> round:int
+  -> Flambda.program
+  -> Flambda.program

middle_end/inline_and_simplify_aux.ml

@@ -0,0 +1,357 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Env = struct
+  type scope = Current | Outer
+
+  type t = {
+    backend : (module Backend_intf.S);
+    round : int;
+    approx : (scope * Simple_value_approx.t) Variable.Map.t;
+    approx_mutable : Simple_value_approx.t Mutable_variable.Map.t;
+    approx_sym : Simple_value_approx.t Symbol.Map.t;
+    current_functions : Set_of_closures_id.Set.t;
+    (* The functions currently being declared: used to avoid inlining
+       recursively *)
+    inlining_level : int;
+    inside_branch : int;
+    (* Number of times "inline" has been called recursively *)
+    freshening : Freshening.t;
+    never_inline : bool ;
+    possible_unrolls : int;
+    closure_depth : int;
+    inlining_stats_closure_stack : Inlining_stats.Closure_stack.t;
+  }
+
+  let create ~never_inline ~backend ~round =
+    let possible_unrolls =
+      Clflags.Int_arg_helper.get ~key:round !Clflags.unroll
+    in
+    { backend;
+      round;
+      approx = Variable.Map.empty;
+      approx_mutable = Mutable_variable.Map.empty;
+      approx_sym = Symbol.Map.empty;
+      current_functions = Set_of_closures_id.Set.empty;
+      inlining_level = 0;
+      inside_branch = 0;
+      freshening = Freshening.empty;
+      never_inline;
+      possible_unrolls;
+      closure_depth = 0;
+      inlining_stats_closure_stack =
+        Inlining_stats.Closure_stack.create ();
+    }
+
+  let backend t = t.backend
+  let round t = t.round
+
+  let local env =
+    { env with
+      approx = Variable.Map.empty;
+      freshening = Freshening.empty_preserving_activation_state env.freshening;
+    }
+
+  let inlining_level_up env =
+    let max_level =
+      Clflags.Int_arg_helper.get ~key:(env.round) !Clflags.max_inlining_depth
+    in
+    if (env.inlining_level + 1) > max_level then
+      Misc.fatal_error "Inlining level increased above maximum";
+    { env with inlining_level = env.inlining_level + 1 }
+
+  let print ppf t =
+    Format.fprintf ppf "Environment maps: %a@.Freshening: %a@."
+        Variable.Set.print (Variable.Map.keys t.approx)
+        Freshening.print t.freshening
+
+  let mem t var = Variable.Map.mem var t.approx
+
+  let add_internal t var (approx : Simple_value_approx.t) ~scope =
+    let approx =
+      (* The semantics of this [match] are what preserve the property
+         described at the top of simple_value_approx.mli, namely that when a
+         [var] is mem on an approximation (amongst many possible [var]s),
+         it is the one with the outermost scope. *)
+      match approx.var with
+      | Some var when mem t var -> approx
+      | _ -> Simple_value_approx.augment_with_variable approx var
+    in
+    { t with approx = Variable.Map.add var (scope, approx) t.approx }
+
+  let add t var approx = add_internal t var approx ~scope:Current
+  let add_outer_scope t var approx = add_internal t var approx ~scope:Outer
+
+  let add_mutable t mut_var approx =
+    { t with approx_mutable =
+        Mutable_variable.Map.add mut_var approx t.approx_mutable;
+    }
+
+  let really_import_approx t approx =
+    let module Backend = (val (t.backend) : Backend_intf.S) in
+    Backend.really_import_approx approx
+
+  let really_import_approx_with_scope t (scope, approx) =
+    scope, really_import_approx t approx
+
+  let find_symbol_exn t symbol =
+    really_import_approx t
+      (Symbol.Map.find symbol t.approx_sym)
+
+  let find_symbol_opt t symbol =
+    try Some (really_import_approx t
+                (Symbol.Map.find symbol t.approx_sym))
+    with Not_found -> None
+
+  let find_symbol_fatal t symbol =
+    match find_symbol_exn t symbol with
+    | exception Not_found ->
+      Misc.fatal_errorf "Symbol %a is unbound.  Maybe there is a missing \
+          [Let_symbol], [Import_symbol] or similar?"
+        Symbol.print symbol
+    | approx -> approx
+
+  let find_or_load_symbol t symbol =
+    match find_symbol_exn t symbol with
+    | exception Not_found ->
+      if Compilation_unit.equal
+          (Compilation_unit.get_current_exn ())
+          (Symbol.compilation_unit symbol)
+      then
+        Misc.fatal_errorf "Symbol %a from the current compilation unit is unbound. \
+                           Maybe there is a missing [Let_symbol] or similar?"
+          Symbol.print symbol;
+      let module Backend = (val (t.backend) : Backend_intf.S) in
+      Backend.import_symbol symbol
+    | approx -> approx
+
+  let does_not_bind t vars =
+    not (List.exists (mem t) vars)
+
+  let does_not_freshen t vars =
+    Freshening.does_not_freshen t.freshening vars
+
+  let add_symbol t symbol approx =
+    match find_symbol_exn t symbol with
+    | exception Not_found ->
+      { t with
+        approx_sym = Symbol.Map.add symbol approx t.approx_sym;
+      }
+    | _ ->
+      Misc.fatal_errorf "Attempt to redefine symbol %a (to %a) in environment \
+          for [Inline_and_simplify]"
+        Symbol.print symbol
+        Simple_value_approx.print approx
+
+  let redefine_symbol t symbol approx =
+    match find_symbol_exn t symbol with
+    | exception Not_found ->
+      assert false
+    | _ ->
+      { t with
+        approx_sym = Symbol.Map.add symbol approx t.approx_sym;
+      }
+
+  let find_with_scope_exn t id =
+    try
+      really_import_approx_with_scope t
+        (Variable.Map.find id t.approx)
+    with Not_found ->
+      Misc.fatal_errorf "Inlining_env.find_with_scope_exn: Unbound variable \
+          %a@.%s@. Environment: %a@."
+        Variable.print id
+        (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int))
+        print t
+
+  let find_exn t id =
+    snd (find_with_scope_exn t id)
+
+  let find_mutable_exn t mut_var =
+    try Mutable_variable.Map.find mut_var t.approx_mutable
+    with Not_found ->
+      Misc.fatal_errorf "Env.find_mutable_exn: Unbound variable \
+          %a@.%s@. Environment: %a@."
+        Mutable_variable.print mut_var
+        (Printexc.raw_backtrace_to_string (Printexc.get_callstack max_int))
+        print t
+
+  let find_list_exn t vars =
+    List.map (fun var -> find_exn t var) vars
+
+  let find_opt t id =
+    try Some (really_import_approx t
+                (snd (Variable.Map.find id t.approx)))
+    with Not_found -> None
+
+  let activate_freshening t =
+    { t with freshening = Freshening.activate t.freshening }
+
+  let enter_set_of_closures_declaration ident t =
+    { t with
+      current_functions =
+        Set_of_closures_id.Set.add ident t.current_functions; }
+
+  let inside_set_of_closures_declaration closure_id t =
+    Set_of_closures_id.Set.mem closure_id t.current_functions
+
+  let at_toplevel t =
+    t.closure_depth = 0
+
+  let is_inside_branch env = env.inside_branch > 0
+
+  let branch_depth env = env.inside_branch
+
+  let inside_branch t =
+    { t with inside_branch = t.inside_branch + 1 }
+
+  let set_freshening t freshening  =
+    { t with freshening; }
+
+  let increase_closure_depth t =
+    let approx =
+      Variable.Map.map (fun (_scope, approx) -> Outer, approx) t.approx
+    in
+    { t with
+      approx;
+      closure_depth = t.closure_depth + 1;
+    }
+
+  let set_never_inline t =
+    { t with never_inline = true }
+
+  let unrolling_allowed t =
+    t.possible_unrolls > 0
+
+  let inside_unrolled_function t =
+    { t with possible_unrolls = t.possible_unrolls - 1 }
+
+  let inlining_level t = t.inlining_level
+  let freshening t = t.freshening
+  let never_inline t = t.never_inline
+
+  (* CR-soon mshinwell: this is a bit contorted (see use in
+     inlining_decision.ml) *)
+  let note_entering_closure t ~closure_id ~where =
+    { t with
+      inlining_stats_closure_stack =
+        Inlining_stats.Closure_stack.note_entering_closure
+          t.inlining_stats_closure_stack ~closure_id ~where;
+    }
+
+  let enter_closure t ~closure_id ~inline_inside ~where ~f =
+    let t =
+      if inline_inside then t
+      else set_never_inline t
+    in
+    f (note_entering_closure t ~closure_id ~where)
+
+  let inlining_stats_closure_stack t = t.inlining_stats_closure_stack
+end
+
+let initial_inlining_threshold ~round : Inlining_cost.Threshold.t =
+  let unscaled =
+    Clflags.Float_arg_helper.get ~key:round !Clflags.inline_threshold
+  in
+  (* CR-soon pchambart: Add a warning if this is too big
+     mshinwell: later *)
+  Can_inline_if_no_larger_than
+    (int_of_float
+      (unscaled *. float_of_int Inlining_cost.scale_inline_threshold_by))
+
+let initial_inlining_toplevel_threshold ~round : Inlining_cost.Threshold.t =
+  let ordinary_threshold =
+    Clflags.Float_arg_helper.get ~key:round !Clflags.inline_threshold
+  in
+  let toplevel_threshold =
+    Clflags.Int_arg_helper.get ~key:round !Clflags.inline_toplevel_threshold
+  in
+  let unscaled =
+    (int_of_float ordinary_threshold) + toplevel_threshold
+  in
+  (* CR-soon pchambart: Add a warning if this is too big
+     mshinwell: later *)
+  Can_inline_if_no_larger_than
+    (unscaled * Inlining_cost.scale_inline_threshold_by)
+
+module Result = struct
+  module Int = Numbers.Int
+
+  type t =
+    { approx : Simple_value_approx.t;
+      used_static_exceptions : Static_exception.Set.t;
+      inlining_threshold : Inlining_cost.Threshold.t option;
+      benefit : Inlining_cost.Benefit.t;
+      num_direct_applications : int;
+    }
+
+  let create () =
+    { approx = Simple_value_approx.value_unknown Other;
+      used_static_exceptions = Static_exception.Set.empty;
+      inlining_threshold = None;
+      benefit = Inlining_cost.Benefit.zero;
+      num_direct_applications = 0;
+    }
+
+  let approx t = t.approx
+  let set_approx t approx = { t with approx }
+
+  let use_static_exception t i =
+    { t with
+      used_static_exceptions =
+        Static_exception.Set.add i t.used_static_exceptions;
+    }
+
+  let used_static_exceptions t = t.used_static_exceptions
+
+  let exit_scope_catch t i =
+    { t with
+      used_static_exceptions =
+        Static_exception.Set.remove i t.used_static_exceptions;
+    }
+
+  let map_benefit t f =
+    { t with benefit = f t.benefit }
+
+  let benefit t = t.benefit
+
+  let reset_benefit t =
+    { t with benefit = Inlining_cost.Benefit.zero; }
+
+  let set_inlining_threshold t inlining_threshold =
+    { t with inlining_threshold }
+
+  let add_inlining_threshold t j =
+    match t.inlining_threshold with
+    | None -> t
+    | Some i ->
+      let inlining_threshold = Some (Inlining_cost.Threshold.add i j) in
+      { t with inlining_threshold }
+
+  let sub_inlining_threshold t j =
+    match t.inlining_threshold with
+    | None -> t
+    | Some i ->
+      let inlining_threshold = Some (Inlining_cost.Threshold.sub i j) in
+      { t with inlining_threshold }
+
+  let inlining_threshold t = t.inlining_threshold
+
+  let seen_direct_application t =
+    { t with num_direct_applications = t.num_direct_applications + 1; }
+
+  let num_direct_applications t =
+    t.num_direct_applications
+end

middle_end/inline_and_simplify_aux.mli

@@ -0,0 +1,251 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Environments and result structures used during inlining and
+    simplification.  (See inline_and_simplify.ml.) *)
+
+module Env : sig
+  (** Environments follow the lexical scopes of the program. *)
+  type t
+
+  (** Create a new environment.  If [never_inline] is true then the returned
+      environment will prevent [Inline_and_simplify] from inlining.  The
+      [backend] parameter is used for passing information about the compiler
+      backend being used.
+      Newly-created environments have inactive [Freshening]s (see below) and do
+      not initially hold any approximation information. *)
+  val create
+     : never_inline:bool
+    -> backend:(module Backend_intf.S)
+    -> round:int
+    -> t
+
+  (** Obtain the first-class module that gives information about the
+      compiler backend being used for compilation. *)
+  val backend : t -> (module Backend_intf.S)
+
+  (** Which simplification round we are currently in. *)
+  val round : t -> int
+
+  (** Add the approximation of a variable---that is to say, some knowledge
+      about the value(s) the variable may take on at runtime---to the
+      environment. *)
+  val add : t -> Variable.t -> Simple_value_approx.t -> t
+
+  val add_outer_scope : t -> Variable.t -> Simple_value_approx.t -> t
+
+  (** Like [add], but for mutable variables. *)
+  val add_mutable : t -> Mutable_variable.t -> Simple_value_approx.t -> t
+
+  (** Find the approximation of a given variable, raising a fatal error if
+      the environment does not know about the variable.  Use [find_opt]
+      instead if you need to catch the failure case. *)
+  val find_exn : t -> Variable.t -> Simple_value_approx.t
+
+  (** Like [find_exn], but for mutable variables. *)
+  val find_mutable_exn : t -> Mutable_variable.t -> Simple_value_approx.t
+
+  type scope = Current | Outer
+
+  val find_with_scope_exn : t -> Variable.t -> scope * Simple_value_approx.t
+
+  (** Like [find_exn], but intended for use where the "not present in
+      environment" case is to be handled by the caller. *)
+  val find_opt : t -> Variable.t -> Simple_value_approx.t option
+
+  (** Like [find_exn], but for a list of variables. *)
+  val find_list_exn : t -> Variable.t list -> Simple_value_approx.t list
+
+  val does_not_bind : t -> Variable.t list -> bool
+
+  val does_not_freshen : t -> Variable.t list -> bool
+
+  val add_symbol : t -> Symbol.t -> Simple_value_approx.t -> t
+  val redefine_symbol : t -> Symbol.t -> Simple_value_approx.t -> t
+  val find_symbol_exn : t -> Symbol.t -> Simple_value_approx.t
+  val find_symbol_opt : t -> Symbol.t -> Simple_value_approx.t option
+  val find_symbol_fatal : t -> Symbol.t -> Simple_value_approx.t
+
+  (* Like [find_symbol_exn], but load the symbol approximation using
+     the backend if not available in the environment. *)
+  val find_or_load_symbol : t -> Symbol.t -> Simple_value_approx.t
+
+  (** Whether the environment has an approximation for the given variable. *)
+  val mem : t -> Variable.t -> bool
+
+  (** Return the freshening that should be applied to variables when
+      rewriting code (in [Inline_and_simplify], etc.) using the given
+      environment. *)
+  val freshening : t -> Freshening.t
+
+  (** Set the freshening that should be used as per [freshening], above. *)
+  val set_freshening : t -> Freshening.t -> t
+
+  (** Causes every bound variable in code rewritten during inlining and
+      simplification, using the given environment, to be freshened.  This is
+      used when descending into subexpressions substituted into existing
+      expressions. *)
+  val activate_freshening : t -> t
+
+  (** Erase all variable approximation information and freshening information
+      from the given environment.  However, the freshening activation state
+      is preserved.  This function is used when rewriting inside a function
+      declaration, to avoid (due to a compiler bug) accidental use of
+      variables from outer scopes that are not accessible. *)
+  val local : t -> t
+
+  (** Note that the inliner is descending into a function body from the given
+      set of closures.  A set of such descents is maintained. *)
+  (* CR-someday mshinwell: consider changing name to remove "declaration".  Also,
+     isn't this the inlining stack?  Maybe we can use that instead. *)
+  val enter_set_of_closures_declaration : Set_of_closures_id.t -> t -> t
+
+  (** Determine whether the inliner is currently inside a function body from
+      the given set of closures.  This is used to detect whether a given
+      function call refers to a function which exists somewhere on the current
+      inlining stack. *)
+  val inside_set_of_closures_declaration : Set_of_closures_id.t -> t -> bool
+
+  (** Not inside a closure declaration.
+      Toplevel code is the one evaluated when the compilation unit is
+      loaded *)
+  val at_toplevel : t -> bool
+
+  val is_inside_branch : t -> bool
+  val branch_depth : t -> int
+  val inside_branch : t -> t
+
+  val increase_closure_depth : t -> t
+
+  (** Mark that call sites contained within code rewritten using the given
+      environment should never be replaced by inlined (or unrolled) versions
+      of the callee(s). *)
+  val set_never_inline : t -> t
+
+  (** Return whether [set_never_inline] is currently in effect on the given
+      environment. *)
+  val never_inline : t -> bool
+
+  val inlining_level : t -> int
+
+  (** Mark that this environment is used to rewrite code for inlining. This is
+      used by the inlining heuristics to decide wether to continue.
+      Unconditionally inlined does not take this into account. *)
+  val inlining_level_up : t -> t
+
+  (** Whether it is permissible to unroll a call to a recursive function
+      in the given environment. *)
+  val unrolling_allowed : t -> bool
+
+  (** Whether the given environment is currently being used to rewrite the
+      body of an unrolled recursive function. *)
+  val inside_unrolled_function : t -> t
+
+  (** If collecting inlining statistics, record that the inliner is about to
+      descend into [closure_id].  This information enables us to produce a
+      stack of closures that form a kind of context around an inlining
+      decision point. *)
+  val note_entering_closure
+     : t
+    -> closure_id:Closure_id.t
+    -> where:Inlining_stats_types.where_entering_closure
+    -> t
+
+  (** Update a given environment to record that the inliner is about to
+      descend into [closure_id] and pass the resulting environment to [f].
+      If [inline_inside] is [false] then the environment passed to [f] will be
+      marked as [never_inline] (see above). *)
+  val enter_closure
+     : t
+    -> closure_id:Closure_id.t
+    -> inline_inside:bool
+    -> where:Inlining_stats_types.where_entering_closure
+    -> f:(t -> 'a)
+    -> 'a
+
+  (** Return the closure stack, used for the generation of inlining statistics,
+      stored inside the given environment. *)
+  val inlining_stats_closure_stack
+     : t
+    -> Inlining_stats.Closure_stack.t
+
+  (** Print a human-readable version of the given environment. *)
+  val print : Format.formatter -> t -> unit
+end
+
+module Result : sig
+  (** Result structures approximately follow the evaluation order of the
+      program.  They are returned by the simplification algorithm acting on
+      an Flambda subexpression. *)
+  type t
+
+  val create : unit -> t
+
+  (** The approximation of the subexpression that has just been
+      simplified. *)
+  val approx : t -> Simple_value_approx.t
+
+  (** Set the approximation of the subexpression that has just been
+      simplified.  Typically used just before returning from a case of the
+      simplification algorithm. *)
+  val set_approx : t -> Simple_value_approx.t -> t
+
+  (** All static exceptions for which [use_staticfail] has been called on
+      the given result structure. *)
+  val used_static_exceptions : t -> Static_exception.Set.t
+
+  (** Mark that the given static exception has been used. *)
+  val use_static_exception : t -> Static_exception.t -> t
+
+  (** Mark that we are moving up out of the scope of a static-catch block
+      that catches the given static exception identifier.  This has the effect
+      of removing the identifier from the [used_staticfail] set. *)
+  val exit_scope_catch : t -> Static_exception.t -> t
+
+  (** The benefit to be gained by inlining the subexpression whose
+      simplification yielded the given result structure. *)
+  val benefit : t -> Inlining_cost.Benefit.t
+
+  (** Apply a transformation to the inlining benefit stored within the
+      given result structure. *)
+  val map_benefit
+    : t
+    -> (Inlining_cost.Benefit.t -> Inlining_cost.Benefit.t)
+    -> t
+
+  (** Set the benefit of inlining the subexpression corresponding to the
+      given result structure to zero. *)
+  val reset_benefit : t -> t
+
+  val set_inlining_threshold :
+    t -> Inlining_cost.Threshold.t option -> t
+  val add_inlining_threshold :
+    t -> Inlining_cost.Threshold.t -> t
+  val sub_inlining_threshold :
+    t -> Inlining_cost.Threshold.t -> t
+  val inlining_threshold : t -> Inlining_cost.Threshold.t option
+
+  val seen_direct_application : t -> t
+  val num_direct_applications : t -> int
+
+end
+
+(** Command line argument -inline *)
+val initial_inlining_threshold : round:int -> Inlining_cost.Threshold.t
+
+(** Command line argument -inline-toplevel *)
+val initial_inlining_toplevel_threshold
+  : round:int -> Inlining_cost.Threshold.t

middle_end/inlining_cost.ml

@@ -0,0 +1,527 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Simple approximation of the space cost of a primitive. *)
+
+let prim_size (prim : Lambda.primitive) args =
+  match prim with
+  | Pidentity -> 0
+  | Pgetglobal _ -> 1
+  | Psetglobal _ -> 1
+  | Pmakeblock _ -> 5 + List.length args
+  | Pfield _ -> 1
+  | Psetfield (_, isptr, init) ->
+    begin match init with
+    | Initialization -> 1  (* never causes a write barrier hit *)
+    | Assignment ->
+      match isptr with
+      | Pointer -> 4
+      | Immediate -> 1
+    end
+  | Pfloatfield _ -> 1
+  | Psetfloatfield _ -> 1
+  | Pduprecord _ -> 10 + List.length args
+  | Pccall p -> (if p.Primitive.prim_alloc then 10 else 4) + List.length args
+  | Praise _ -> 4
+  | Pstringlength -> 5
+  | Pstringrefs | Pstringsets -> 6
+  | Pmakearray _ -> 5 + List.length args
+  | Parraylength Pgenarray -> 6
+  | Parraylength _ -> 2
+  | Parrayrefu Pgenarray -> 12
+  | Parrayrefu _ -> 2
+  | Parraysetu Pgenarray -> 16
+  | Parraysetu _ -> 4
+  | Parrayrefs Pgenarray -> 18
+  | Parrayrefs _ -> 8
+  | Parraysets Pgenarray -> 22
+  | Parraysets _ -> 10
+  | Pbittest -> 3
+  | Pbigarrayref (_, ndims, _, _) -> 4 + ndims * 6
+  | Pbigarrayset (_, ndims, _, _) -> 4 + ndims * 6
+  | Psequand | Psequor ->
+    Misc.fatal_error "Psequand and Psequor are not allowed in Prim \
+        expressions; translate out instead (cf. closure_conversion.ml)"
+  (* CR mshinwell: This match must be made exhaustive. *)
+  | _ -> 2 (* arithmetic and comparisons *)
+
+(* Simple approximation of the space cost of an Flambda expression. *)
+
+let direct_call_size = 4
+let project_size = 1
+
+let lambda_smaller' lam ~than:threshold =
+  let size = ref 0 in
+  let rec lambda_size (lam : Flambda.t) =
+    if !size > threshold then raise Exit;
+    match lam with
+    | Var _ -> ()
+    | Apply ({ func = _; args = _; kind = direct }) ->
+      let call_cost =
+        match direct with Indirect -> 6 | Direct _ -> direct_call_size
+      in
+      size := !size + call_cost
+    | Assign _ -> incr size
+    | Send _ -> size := !size + 8
+    | Proved_unreachable -> ()
+    | Let { defining_expr; body; _ } ->
+      lambda_named_size defining_expr;
+      lambda_size body
+    | Let_mutable (_, _, body) -> lambda_size body
+    | Let_rec (bindings, body) ->
+      List.iter (fun (_, lam) -> lambda_named_size lam) bindings;
+      lambda_size body
+    | Switch (_, sw) ->
+      let aux = function _::_::_ -> size := !size + 5 | _ -> () in
+      aux sw.consts; aux sw.blocks;
+      List.iter (fun (_, lam) -> lambda_size lam) sw.consts;
+      List.iter (fun (_, lam) -> lambda_size lam) sw.blocks
+    | String_switch (_, sw, def) ->
+      List.iter (fun (_, lam) ->
+          size := !size + 2;
+          lambda_size lam)
+        sw;
+      Misc.may lambda_size def
+    | Static_raise _ -> ()
+    | Static_catch (_, _, body, handler) ->
+      incr size; lambda_size body; lambda_size handler
+    | Try_with (body, _, handler) ->
+      size := !size + 8; lambda_size body; lambda_size handler
+    | If_then_else (_, ifso, ifnot) ->
+      size := !size + 2;
+      lambda_size ifso; lambda_size ifnot
+    | While (cond, body) ->
+      size := !size + 2; lambda_size cond; lambda_size body
+    | For { body; _ } ->
+      size := !size + 4; lambda_size body
+  and lambda_named_size (named : Flambda.named) =
+    if !size > threshold then raise Exit;
+    match named with
+    | Symbol _ | Read_mutable _ -> ()
+    (* CR mshinwell: are these cases correct? *)
+    | Const _ | Allocated_const _ -> incr size
+    | Read_symbol_field _ -> incr size
+    | Set_of_closures ({ function_decls = ffuns }) ->
+      Variable.Map.iter (fun _ (ffun : Flambda.function_declaration) ->
+          lambda_size ffun.body)
+        ffuns.funs
+    | Project_closure _ | Project_var _ ->
+      size := !size + project_size
+    | Move_within_set_of_closures _ ->
+      incr size
+    | Prim (prim, args, _) ->
+      size := !size + prim_size prim args
+    | Expr expr -> lambda_size expr
+  in
+  try
+    lambda_size lam;
+    if !size <= threshold then Some !size
+    else None
+  with Exit ->
+    None
+
+let lambda_size lam =
+  match lambda_smaller' lam ~than:max_int with
+  | Some size ->
+      size
+  | None ->
+      (* There is no way that an expression of size max_int could fit in
+         memory. *)
+      assert false
+
+module Threshold = struct
+
+  type t =
+    | Never_inline
+    | Can_inline_if_no_larger_than of int
+
+  let add t1 t2 =
+    match t1, t2 with
+    | Never_inline, t -> t
+    | t, Never_inline -> t
+    | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 ->
+        Can_inline_if_no_larger_than (i1 + i2)
+
+  let sub t1 t2 =
+    match t1, t2 with
+    | Never_inline, _ -> Never_inline
+    | t, Never_inline -> t
+    | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 ->
+        if i1 > i2 then Can_inline_if_no_larger_than (i1 - i2)
+        else Never_inline
+
+  let min t1 t2 =
+    match t1, t2 with
+    | Never_inline, _ -> Never_inline
+    | _, Never_inline -> Never_inline
+    | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 ->
+      Can_inline_if_no_larger_than (min i1 i2)
+
+end
+
+let can_try_inlining lam inlining_threshold ~number_of_arguments
+      ~size_from_approximation =
+  match inlining_threshold with
+  | Threshold.Never_inline -> Threshold.Never_inline
+  | Threshold.Can_inline_if_no_larger_than inlining_threshold ->
+    let bonus =
+      (* removing a call will reduce the size by at least the number
+         of arguments *)
+      number_of_arguments
+    in
+    let size =
+      let than = inlining_threshold + bonus in
+      match size_from_approximation with
+      | Some size -> if size <= than then Some size else None
+      | None -> lambda_smaller' lam ~than
+    in
+    match size with
+    | None -> Threshold.Never_inline
+    | Some size ->
+      Threshold.Can_inline_if_no_larger_than
+        (inlining_threshold - size + bonus)
+
+let lambda_smaller lam ~than =
+  lambda_smaller' lam ~than <> None
+
+let can_inline lam inlining_threshold ~bonus =
+  match inlining_threshold with
+  | Threshold.Never_inline -> false
+  | Threshold.Can_inline_if_no_larger_than inlining_threshold ->
+     lambda_smaller
+       lam
+       ~than:(inlining_threshold + bonus)
+
+let cost (flag : Clflags.Int_arg_helper.parsed) ~round =
+  Clflags.Int_arg_helper.get ~key:round flag
+
+let benefit_factor = 1
+
+module Benefit = struct
+  type t = {
+    remove_call : int;
+    remove_alloc : int;
+    remove_prim : int;
+    remove_branch : int;
+    (* CR-someday pchambart: branch_benefit : t list; *)
+    direct_call_of_indirect : int;
+    requested_inline : int;
+    (* Benefit to compensate the size of functions marked for inlining *)
+  }
+
+  let zero = {
+    remove_call = 0;
+    remove_alloc = 0;
+    remove_prim = 0;
+    remove_branch = 0;
+    direct_call_of_indirect = 0;
+    requested_inline = 0;
+  }
+
+  let remove_call t = { t with remove_call = t.remove_call + 1; }
+  let remove_alloc t = { t with remove_alloc = t.remove_alloc + 1; }
+  let remove_prim t = { t with remove_prim = t.remove_prim + 1; }
+  let remove_branch t = { t with remove_branch = t.remove_branch + 1; }
+  let direct_call_of_indirect t =
+    { t with direct_call_of_indirect = t.direct_call_of_indirect + 1; }
+  let requested_inline t ~size_of =
+    let size = lambda_size size_of in
+    { t with requested_inline = t.requested_inline + size; }
+
+  let remove_code_helper b (flam : Flambda.t) =
+    match flam with
+    | Assign _ -> b := remove_prim !b
+    | Switch _ | String_switch _ | Static_raise _ | Try_with _
+    | If_then_else _ | While _ | For _ -> b := remove_branch !b
+    | Apply _ | Send _ -> b := remove_call !b
+    | Let _ | Let_mutable _ | Let_rec _ | Proved_unreachable | Var _
+    | Static_catch _ -> ()
+
+  let remove_code_helper_named b (named : Flambda.named) =
+    match named with
+    | Set_of_closures _
+    | Prim ((Pmakearray _ | Pmakeblock _ | Pduprecord _), _, _) ->
+      b := remove_alloc !b
+      (* CR pchambart: should we consider that boxed integer and float
+         operations are allocations ? *)
+      (* CR mshinwell for pchambart: check closure & const cases carefully *)
+    | Prim _ | Project_closure _ | Project_var _
+    | Move_within_set_of_closures _ -> b := remove_prim !b
+    | Read_symbol_field _ -> () (* CR mshinwell: might be wrong *)
+    | Symbol _ | Read_mutable _ | Allocated_const _ | Const _ | Expr _ -> ()
+
+  let remove_code lam b =
+    let b = ref b in
+    Flambda_iterators.iter_toplevel (remove_code_helper b)
+      (remove_code_helper_named b) lam;
+    !b
+
+  let remove_code_named lam b =
+    let b = ref b in
+    Flambda_iterators.iter_named_toplevel (remove_code_helper b)
+      (remove_code_helper_named b) lam;
+    !b
+
+  let print ppf b =
+    Format.fprintf ppf "@[remove_call: %i@ remove_alloc: %i@ \
+                        remove_prim: %i@ remove_branch: %i@ \
+                        direct: %i@ requested: %i@]"
+      b.remove_call
+      b.remove_alloc
+      b.remove_prim
+      b.remove_branch
+      b.direct_call_of_indirect
+      b.requested_inline
+
+  let evaluate t ~round : int =
+    benefit_factor *
+      (t.remove_call * (cost !Clflags.inline_call_cost ~round)
+       + t.remove_alloc * (cost !Clflags.inline_alloc_cost ~round)
+       + t.remove_prim * (cost !Clflags.inline_prim_cost ~round)
+       + t.remove_branch * (cost !Clflags.inline_branch_cost ~round)
+       + t.direct_call_of_indirect * (cost !Clflags.inline_indirect_cost ~round))
+    + t.requested_inline
+
+  let (+) t1 t2 = {
+    remove_call = t1.remove_call + t2.remove_call;
+    remove_alloc = t1.remove_alloc + t2.remove_alloc;
+    remove_prim = t1.remove_prim + t2.remove_prim;
+    remove_branch = t1.remove_branch + t2.remove_branch;
+    direct_call_of_indirect =
+      t1.direct_call_of_indirect + t2.direct_call_of_indirect;
+    requested_inline = t1.requested_inline + t2.requested_inline;
+  }
+
+  let max ~round t1 t2 =
+    let c1 = evaluate ~round t1 in
+    let c2 = evaluate ~round t2 in
+    if c1 > c2 then t1 else t2
+
+end
+
+module Whether_sufficient_benefit = struct
+  type t = {
+    round : int;
+    benefit : Benefit.t;
+    toplevel : bool;
+    branch_depth : int;
+    lifting : bool;
+    original_size : int;
+    new_size : int;
+    evaluated_benefit : int;
+    estimate : bool;
+  }
+
+  let create ~original ~toplevel ~branch_depth lam ~benefit ~lifting ~round =
+    let evaluated_benefit = Benefit.evaluate benefit ~round in
+    { round; benefit; toplevel; branch_depth; lifting;
+      original_size = lambda_size original;
+      new_size = lambda_size lam;
+      evaluated_benefit;
+      estimate = false;
+    }
+
+  let create_estimate ~original_size ~toplevel ~branch_depth ~new_size
+        ~benefit ~lifting ~round =
+    let evaluated_benefit = Benefit.evaluate benefit ~round in
+    { round; benefit; toplevel; branch_depth; lifting; original_size;
+      new_size; evaluated_benefit; estimate = true;
+    }
+
+  let correct_branch_factor f =
+    f = f (* is not nan *)
+    && f >= 0.
+
+  let evaluate t =
+    let estimated_benefit =
+      if t.toplevel && t.lifting && t.branch_depth = 0 then begin
+        let lifting_benefit =
+          Clflags.Int_arg_helper.get ~key:t.round !Clflags.inline_lifting_benefit
+        in
+          float (t.evaluated_benefit + lifting_benefit)
+      end else begin
+        (* The estimated benefit is the evaluated benefit times an
+           estimation of the probability that the branch does not matter
+           for performances (is cold). The probability is very roughtly
+           estimated by considering that for every branching the
+           sub-expressions has the same [1 / (1 + factor)] probability
+           [p] of being cold. Hence the probability for the current
+           call to be cold is [p ^ number of nested branch].
+
+           The probability is expressed as [1 / (1 + factor)] rather
+           than letting the user directly provide [p], since for every
+           positive value of [factor] [p] is in [0, 1]. *)
+        let branch_never_taken_estimated_probability =
+          let branch_inline_factor =
+            Clflags.Float_arg_helper.get ~key:t.round !Clflags.branch_inline_factor
+          in
+          (* CR pchambart to pchambart: change this assert to a warning *)
+          assert(correct_branch_factor branch_inline_factor);
+          1. /. (1. +. branch_inline_factor)
+        in
+        let call_estimated_probability =
+          branch_never_taken_estimated_probability ** float t.branch_depth
+        in
+          float t.evaluated_benefit *. call_estimated_probability
+      end
+    in
+      float t.new_size -. estimated_benefit <= float t.original_size
+
+
+  let to_string t =
+    let lifting = t.toplevel && t.lifting && t.branch_depth = 0 in
+    let evaluated_benefit =
+      if lifting then
+        let lifting_benefit =
+          Clflags.Int_arg_helper.get ~key:t.round !Clflags.inline_lifting_benefit
+        in
+        t.evaluated_benefit + lifting_benefit
+      else t.evaluated_benefit
+    in
+    let estimate = if t.estimate then "<" else "=" in
+      Printf.sprintf "{benefit%s{call=%d,alloc=%d,prim=%i,branch=%i,indirect=%i,req=%i,\
+                      lifting=%b}, orig_size=%d,new_size=%d,eval_size=%d,eval_benefit%s%d,\
+                      branch_depth=%d}=%s"
+        estimate
+        t.benefit.remove_call
+        t.benefit.remove_alloc
+        t.benefit.remove_prim
+        t.benefit.remove_branch
+        t.benefit.direct_call_of_indirect
+        t.benefit.requested_inline
+        lifting
+        t.original_size
+        t.new_size
+        (t.original_size - t.new_size)
+        estimate
+        evaluated_benefit
+        t.branch_depth
+        (if evaluate t then "yes" else "no")
+end
+
+let scale_inline_threshold_by = 8
+
+let default_toplevel_multiplier = 8
+
+  (* CR-soon mshinwell for mshinwell: hastily-written comment, to review *)
+  (* We may in [Inlining_decision] need to measure the size of functions
+     that are below the inlining threshold.  We also need to measure with
+     regard to benefit (see [Inlining_decision.inline_non_recursive).  The
+     intuition for having a cached size in the second case is as follows.
+     If a function's body exceeds some maximum size and its argument
+     approximations are unknown (meaning that we cannot materially simplify
+     it further), we can infer without examining the function's body that
+     it cannot be inlined.  The aim is to speed up [Inlining_decision].
+
+     The "original size" is [Inlining_cost.direct_call_size].  The "new size" is
+     the size of the function's body plus [Inlining_cost.project_size] for each
+     free variable and mutually recursive function accessed through the closure.
+
+     To be inlined we need:
+
+       body_size
+       + (closure_accesses * project_size)            <=   direct_call_size
+       - (evaluated_benefit * call_prob)
+
+     i.e.:
+
+       body_size <= direct_call_size
+                    + (evaluated_benefit * call_prob)
+                    - (closure_accesses * project_size)
+
+     In this case we would be removing a single call and a projection for each
+     free variable that can be accessed directly (i.e. not via the closure
+     or the internal variable).
+
+       evaluated_benefit =
+         benefit_factor
+         * (inline_call_cost
+         + ((free_variables - indirect_accesses) * inline_prim_cost))
+
+     (For [inline_call_cost] and [inline_prim_cost], we use the maximum these
+     might be across any round.)
+
+     Substituting:
+
+       body_size <= direct_call_size
+                      + (benefit_factor
+                          * (inline_call_cost
+                             + ((free_variables - indirect_accesses)
+                                * inline_prim_cost)))
+                        * call_prob
+                      - (closure_accesses * project_size)
+
+     Rearranging:
+
+       body_size <= direct_call_size
+                      + (inline_call_cost * benefit_factor * call_prob)
+                      + (free_variables * inline_prim_cost
+                           * benefit_factor * call_prob)
+                      - (indirect_accesses * inline_prim_cost
+                           * benefit_factor * call_prob)
+                      - (closure_accesses * project_size)
+
+     The upper bound for the right-hand side is when call_prob = 1.0,
+     indirect_accesses = 0 and closure_accesses = 0, giving:
+
+       direct_call_size
+         + (inline_call_cost * benefit_factor)
+         + (free_variables * inline_prim_cost * benefit_factor)
+
+     So we should measure all functions at or below this size, but also record
+     the size discovered, so we can later re-check (without examining the body)
+     when we know [call_prob], [indirect_accesses] and [closure_accesses].
+
+     This number is split into parts dependent and independent of the
+     number of free variables:
+
+       base = direct_call_size + (inline_call_cost * benefit_factor)
+
+       multiplier = inline_prim_cost * benefit_factor
+
+       body_size <= base + free_variables * multiplier
+
+  *)
+let maximum_interesting_size_of_function_body_base =
+  lazy begin
+    let max_cost = ref 0 in
+    for round = 0 to !Clflags.simplify_rounds - 1 do
+      let max_size =
+        let inline_call_cost = cost !Clflags.inline_call_cost ~round in
+        direct_call_size + (inline_call_cost * benefit_factor)
+      in
+      max_cost := max !max_cost max_size
+    done;
+    !max_cost
+  end
+
+let maximum_interesting_size_of_function_body_multiplier =
+  lazy begin
+    let max_cost = ref 0 in
+    for round = 0 to !Clflags.simplify_rounds - 1 do
+      let max_size =
+        let inline_prim_cost = cost !Clflags.inline_prim_cost ~round in
+        inline_prim_cost * benefit_factor
+      in
+      max_cost := max !max_cost max_size
+    done;
+    !max_cost
+  end
+
+let maximum_interesting_size_of_function_body num_free_variables =
+  let base = Lazy.force maximum_interesting_size_of_function_body_base in
+  let multiplier = Lazy.force maximum_interesting_size_of_function_body_multiplier in
+  base + (num_free_variables * multiplier)

middle_end/inlining_cost.mli

@@ -0,0 +1,127 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Measurement of the cost (including cost in space) of Flambda terms
+    in the context of inlining. *)
+
+module Threshold : sig
+
+  (** The maximum size, in some abstract measure of space cost, that an
+     Flambda expression may be in order to be inlined. *)
+  type t =
+    | Never_inline
+    | Can_inline_if_no_larger_than of int
+
+  val add : t -> t -> t
+  val sub : t -> t -> t
+  val min : t -> t -> t
+
+end
+
+(* Determine whether the given Flambda expression has a sufficiently low space
+   cost so as to fit under the given [inlining_threshold].  The [bonus] is
+   added to the threshold before evaluation. *)
+val can_inline
+    : Flambda.t
+  -> Threshold.t
+  -> bonus:int
+  -> bool
+
+(* CR-soon mshinwell for pchambart: I think the name of this function might be
+   misleading.  It should probably reflect the functionality it provides,
+   not the use to which it is put in another module. *)
+(* As for [can_inline], but returns the decision as an inlining threshold.
+   If [Never_inline] is returned, the expression was too large for the
+   input [inlining_threshold].  Otherwise, [Can_inline_if_no_larger_than] is
+   returned, with the constructor argument being the measured estimated size
+   of the expression. *)
+val can_try_inlining
+    : Flambda.t
+  -> Threshold.t
+  -> number_of_arguments:int
+  -> size_from_approximation:int option
+  -> Threshold.t
+
+module Benefit : sig
+  (* A model of the benefit we gain by removing a particular combination
+     of operations.  Such removals are typically performed by inlining (for
+     example, [remove_call]) and simplification (for example, [remove_alloc])
+     passes. *)
+
+  type t
+
+  val zero : t
+  val (+) : t -> t -> t
+  val max : round:int -> t -> t -> t
+
+  val remove_call : t -> t
+  val remove_alloc : t -> t
+  val remove_prim : t -> t
+  val remove_branch : t -> t
+  val direct_call_of_indirect : t -> t
+  val requested_inline : t -> size_of:Flambda.t -> t
+
+  val remove_code : Flambda.t -> t -> t
+  val remove_code_named : Flambda.named -> t -> t
+
+  val print : Format.formatter -> t -> unit
+end
+
+module Whether_sufficient_benefit : sig
+  (* Evaluation of the benefit of removing certain operations against an
+     inlining threshold. *)
+
+  type t
+
+  val create
+     : original:Flambda.t
+    -> toplevel:bool
+    -> branch_depth:int
+    -> Flambda.t
+    -> benefit:Benefit.t
+    -> lifting:bool
+    -> round:int
+    -> t
+
+  val create_estimate
+     : original_size:int
+    -> toplevel:bool
+    -> branch_depth: int
+    -> new_size:int
+    -> benefit:Benefit.t
+    -> lifting:bool
+    -> round:int
+    -> t
+
+  val evaluate : t -> bool
+
+  val to_string : t -> string
+end
+
+val scale_inline_threshold_by : int
+
+val default_toplevel_multiplier : int
+
+val direct_call_size : int
+
+(** If a function body exceeds this size, we can make a fast decision not
+    to inline it (see [Inlining_decision]). *)
+val maximum_interesting_size_of_function_body : int -> int
+
+(** Measure the given expression to determine whether its size is at or
+    below the given threshold.  [None] is returned if it is too big; otherwise
+    [Some] is returned with the measured size. *)
+val lambda_smaller' : Flambda.expr -> than:int -> int option

middle_end/inlining_decision.ml

@@ -0,0 +1,551 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+module A = Simple_value_approx
+module E = Inline_and_simplify_aux.Env
+module R = Inline_and_simplify_aux.Result
+module U = Flambda_utils
+module W = Inlining_cost.Whether_sufficient_benefit
+module T = Inlining_cost.Threshold
+
+let inline_non_recursive env r ~function_decls ~lhs_of_application
+    ~closure_id_being_applied ~(function_decl : Flambda.function_declaration)
+    ~value_set_of_closures ~only_use_of_function ~original
+    ~(args : Variable.t list) ~size_from_approximation ~simplify
+    ~always_inline ~(inline_requested : Lambda.inline_attribute)
+    ~(made_decision : Inlining_stats_types.Decision.t -> unit) =
+  (* When all of the arguments to the function being inlined are unknown, then
+     we cannot materially simplify the function.  As such, we know what the
+     benefit of inlining it would be: just removing the call.  In this case
+     we may be able to prove the function cannot be inlined without traversing
+     its body.
+     Note that if the function is sufficiently small, we still have to call
+     [simplify], because the body needs freshening before substitution.
+  *)
+  (* CR-someday mshinwell: (from GPR#8): pchambart writes:
+
+      We may need to think a bit about that. I can't see a lot of meaningful
+      examples right now, but there are some cases where some optimisation can
+      happen even if we don't know anything about the shape of the arguments.
+
+      For instance
+
+      let f x y = x
+
+      let g x =
+        let y = (x,x) in
+        f x y
+      let f x y =
+        if x = y then ... else ...
+
+      let g x = f x x
+  *)
+  let toplevel = E.at_toplevel env in
+  let branch_depth = E.branch_depth env in
+  let known_to_have_no_benefit =
+    if function_decl.stub || only_use_of_function || always_inline
+         || (toplevel && branch_depth = 0) then
+      false
+    else if A.all_not_useful (E.find_list_exn env args) then
+      match size_from_approximation with
+      | Some body_size ->
+        let wsb =
+          let benefit = Inlining_cost.Benefit.zero in
+          let benefit = Inlining_cost.Benefit.remove_call benefit in
+          let benefit =
+            Variable.Set.fold (fun v acc ->
+                try
+                  let t =
+                    Var_within_closure.Map.find (Var_within_closure.wrap v)
+                      value_set_of_closures.A.bound_vars
+                  in
+                  match t.A.var with
+                  | Some v ->
+                    if (E.mem env v) then Inlining_cost.Benefit.remove_prim acc
+                    else acc
+                  | None -> acc
+                with Not_found -> acc)
+              function_decl.free_variables benefit
+          in
+          W.create_estimate
+            ~original_size:Inlining_cost.direct_call_size
+            ~new_size:body_size
+            ~toplevel:(E.at_toplevel env)
+            ~branch_depth:(E.branch_depth env)
+            ~lifting:function_decl.Flambda.is_a_functor
+            ~round:(E.round env)
+            ~benefit
+        in
+        if (not (W.evaluate wsb)) then begin
+          made_decision (Tried (Copying_body (Evaluated wsb)));
+          true
+        end else false
+      | None ->
+        (* The function is definitely too large to inline given that we don't
+           have any approximations for its arguments.  Further, the body
+           should already have been simplified (inside its declaration), so
+           we also expect no gain from the code below that permits inlining
+           inside the body. *)
+        made_decision (Tried (Copying_body Evaluated_unspecialized));
+        true
+    else begin
+      (* There are useful approximations, so we should simplify. *)
+      false
+    end
+  in
+  if known_to_have_no_benefit then begin
+    None
+  end else begin
+    let body, r_inlined =
+      (* First we construct the code that would result from copying the body of
+         the function, without doing any further inlining upon it, to the call
+         site. *)
+      let r =
+        R.set_inlining_threshold (R.reset_benefit r) (Some T.Never_inline)
+      in
+      Inlining_transforms.inline_by_copying_function_body ~env ~r
+        ~function_decls ~lhs_of_application ~closure_id_being_applied
+        ~inline_requested ~function_decl ~args ~simplify
+    in
+    let num_direct_applications_seen =
+      (R.num_direct_applications r_inlined) - (R.num_direct_applications r)
+    in
+    assert (num_direct_applications_seen >= 0);
+    let keep_inlined_version =
+      if function_decl.stub then begin
+        made_decision (Inlined (Copying_body Stub));
+        true
+      end else if always_inline then begin
+        made_decision (Inlined (Copying_body Unconditionally));
+        true
+      end else if only_use_of_function then begin
+        made_decision (Inlined (Copying_body Decl_local_to_application));
+        true
+      end else begin
+        let sufficient_benefit =
+          W.create ~original body
+            ~toplevel:(E.at_toplevel env)
+            ~branch_depth:(E.branch_depth env)
+            ~lifting:function_decl.Flambda.is_a_functor
+            ~round:(E.round env)
+            ~benefit:(R.benefit r_inlined)
+        in
+        let keep_inlined_version = W.evaluate sufficient_benefit in
+        let decision : Inlining_stats_types.Decision.t =
+          if keep_inlined_version then
+            Inlined (Copying_body (Evaluated sufficient_benefit))
+          else
+            Tried (Copying_body (Evaluated sufficient_benefit))
+        in
+        made_decision decision;
+        keep_inlined_version
+      end
+    in
+    if keep_inlined_version then begin
+      (* Inlining the body of the function was sufficiently beneficial that we
+         will keep it, replacing the call site.  We continue by allowing
+         further inlining within the inlined copy of the body. *)
+      let r =
+        (* The meaning of requesting inlining is that the user ensure
+           that the function has a benefit of at least its size. It is not
+           added to the benefit exposed by the inlining because the user should
+           have taken that into account before annotating the function. *)
+        let function_benefit =
+          if always_inline then
+            Inlining_cost.Benefit.max ~round:(E.round env)
+              Inlining_cost.Benefit.(requested_inline ~size_of:body zero)
+              (R.benefit r_inlined)
+          else
+            R.benefit r_inlined
+        in
+        R.map_benefit r (Inlining_cost.Benefit.(+) function_benefit)
+      in
+      (* [lift_lets_expr] aims to clean up bindings introduced by the
+         inlining. *)
+      let body = Lift_code.lift_lets_expr body ~toplevel:true in
+      let env =
+        E.note_entering_closure env ~closure_id:closure_id_being_applied
+          ~where:Inline_by_copying_function_body
+      in
+      let env =
+        if function_decl.stub ||
+           (* Stub functions should not prevent other functions
+              from being evaluated for inlining *)
+           E.inlining_level env = 0
+           (* If the function was considered for inlining without considering
+              its sub-functions, and it is not below another inlining choice,
+              then we are certain that this code will be kept. *)
+        then env
+        else E.inlining_level_up env
+      in
+      Some (simplify env r body)
+    end else if num_direct_applications_seen < 1 then begin
+      (* Inlining the body of the function did not appear sufficiently
+         beneficial; however, it may become so if we inline within the body
+         first.  We try that next, unless it is known that there are were
+         no direct applications in the simplified body computed above, meaning
+         no opportunities for inlining. *)
+        None
+    end else begin
+      let body, r_inlined =
+        Inlining_transforms.inline_by_copying_function_body ~env
+          ~r:(R.reset_benefit r)
+          ~function_decls ~lhs_of_application ~closure_id_being_applied
+          ~inline_requested ~function_decl ~args ~simplify
+      in
+      let wsb =
+        W.create ~original body
+          ~toplevel:(E.at_toplevel env)
+          ~branch_depth:(E.branch_depth env)
+          ~lifting:function_decl.Flambda.is_a_functor
+          ~round:(E.round env)
+          ~benefit:(R.benefit r_inlined)
+      in
+      let keep_inlined_version = W.evaluate wsb in
+      let decision : Inlining_stats_types.Decision.t =
+        if keep_inlined_version then
+          (* CR mshinwell: This "with_subfunctions" name isn't
+             descriptive enough. *)
+          Inlined (Copying_body_with_subfunctions (Evaluated wsb))
+        else
+          Tried (Copying_body_with_subfunctions (Evaluated wsb))
+      in
+      made_decision decision;
+      if keep_inlined_version then begin
+        Some (body, R.map_benefit r_inlined
+          (Inlining_cost.Benefit.(+) (R.benefit r)))
+      end
+      else begin
+        (* r_inlined contains an approximation that may be invalid for the
+           untransformed expression: it may reference functions that only
+           exists if the body of the function is in fact inlined.
+           If the function approximation contained an approximation that
+           does not depend on the actual values of its arguments, it
+           could be returned instead of [A.value_unknown]. *)
+        None
+      end
+    end
+  end
+
+let unroll_recursive env r ~max_level ~lhs_of_application
+      ~(function_decls : Flambda.function_declarations)
+      ~closure_id_being_applied ~function_decl ~args ~simplify
+      ~original
+      ~(made_decision : Inlining_stats_types.Decision.t -> unit) =
+  let tried_unrolling = ref false in
+  let result =
+    if E.unrolling_allowed env && E.inlining_level env <= max_level then
+      let self_unrolling =
+        E.inside_set_of_closures_declaration function_decls.set_of_closures_id
+          env
+      in
+      if self_unrolling then
+        (* CR mshinwell for pchambart: Should we really completely
+           disallow this?  (Maybe there should be a compiler option?) *)
+        None
+      else begin
+        let env = E.inside_unrolled_function env in
+        let body, r_inlined =
+          Inlining_transforms.inline_by_copying_function_body ~env
+            ~r:(R.reset_benefit r) ~function_decls ~lhs_of_application
+            ~inline_requested:Default_inline
+            ~closure_id_being_applied ~function_decl ~args ~simplify
+        in
+        tried_unrolling := true;
+        let wsb =
+          W.create body ~original
+            ~toplevel:(E.at_toplevel env)
+            ~branch_depth:(E.branch_depth env)
+            ~lifting:false
+            ~round:(E.round env)
+            ~benefit:(R.benefit r_inlined)
+        in
+        let keep_unrolled_version =
+          if W.evaluate wsb then begin
+            made_decision (Inlined (Unrolled wsb));
+            true
+          end else begin
+            (* No decision is recorded here; we will try another strategy
+               below, and then record that we also tried to unroll. *)
+            false
+          end
+        in
+        if keep_unrolled_version then
+          let r =
+            R.map_benefit r_inlined (Inlining_cost.Benefit.(+) (R.benefit r))
+          in
+          Some (body, r)
+        else None
+      end
+    else None
+  in
+  !tried_unrolling, result
+
+let should_duplicate_recursive_function env
+      ~(function_decl : Flambda.function_declaration)
+      ~(function_decls : Flambda.function_declarations)
+      ~(value_set_of_closures : A.value_set_of_closures)
+      ~args_approxs =
+  assert (List.length function_decl.params = List.length args_approxs);
+  !Clflags.inline_recursive_functions
+    && (not (E.inside_set_of_closures_declaration
+      function_decls.set_of_closures_id env))
+    && (not (Variable.Map.is_empty
+      (Lazy.force value_set_of_closures.invariant_params)))
+    && Var_within_closure.Map.is_empty
+      value_set_of_closures.bound_vars (* closed *)
+    && List.exists2 (fun id approx ->
+        A.useful approx
+          && Variable.Map.mem id
+            (Lazy.force value_set_of_closures.invariant_params))
+      function_decl.params args_approxs
+
+let inline_recursive env r ~max_level ~lhs_of_application
+      ~(function_decls : Flambda.function_declarations)
+      ~closure_id_being_applied ~function_decl
+      ~(value_set_of_closures : Simple_value_approx.value_set_of_closures)
+      ~args ~args_approxs ~dbg ~simplify ~original
+      ~(made_decision : Inlining_stats_types.Decision.t -> unit) =
+  let tried_unrolling, unrolling_result =
+    (* First try unrolling the recursive call, if we're allowed to. *)
+    unroll_recursive env r ~max_level ~lhs_of_application ~function_decls
+      ~closure_id_being_applied ~function_decl ~args ~simplify
+      ~original ~made_decision
+  in
+  match unrolling_result with
+  | Some _ -> unrolling_result
+  | None ->
+    (* If unrolling failed, consider duplicating the whole function
+       declaration at the call site, specialising parameters whose arguments
+       we know. *)
+    if should_duplicate_recursive_function env ~function_decls
+        ~function_decl ~value_set_of_closures ~args_approxs
+    then
+      let copied_function_declaration =
+        Inlining_transforms.inline_by_copying_function_declaration ~env
+          ~r:(R.reset_benefit r) ~lhs_of_application
+          ~function_decls ~closure_id_being_applied ~function_decl
+          ~args ~args_approxs
+          ~invariant_params:value_set_of_closures.invariant_params
+          ~specialised_args:value_set_of_closures.specialised_args ~dbg
+          ~simplify
+      in
+      match copied_function_declaration with
+      | Some (expr, r_inlined) ->
+        let wsb =
+          W.create ~original expr
+            ~toplevel:(E.at_toplevel env)
+            ~branch_depth:(E.branch_depth env)
+            ~lifting:false
+            ~round:(E.round env)
+            ~benefit:(R.benefit r_inlined)
+        in
+        let keep_inlined_version = W.evaluate wsb in
+        let decision : Inlining_stats_types.Decision.t =
+          if keep_inlined_version then
+            Inlined (Copying_decl (Tried_unrolling tried_unrolling, wsb))
+          else
+            Tried (Copying_decl (Tried_unrolling tried_unrolling, wsb))
+        in
+        made_decision decision;
+        if keep_inlined_version then
+          let r =
+            R.map_benefit r_inlined (Inlining_cost.Benefit.(+) (R.benefit r))
+          in
+          Some (expr, r)
+        else
+          None
+      | None -> None
+    else begin
+      (* CR lwhite: should include details of why it was not attempted
+         in the reason. *)
+      made_decision
+        (Did_not_try_copying_decl (Tried_unrolling tried_unrolling));
+      None
+    end
+
+let for_call_site ~env ~r ~(function_decls : Flambda.function_declarations)
+      ~lhs_of_application ~closure_id_being_applied
+      ~(function_decl : Flambda.function_declaration)
+      ~(value_set_of_closures : Simple_value_approx.value_set_of_closures)
+      ~args ~args_approxs ~dbg ~simplify ~inline_requested =
+  if List.length args <> List.length args_approxs then begin
+    Misc.fatal_error "Inlining_decision.for_call_site: inconsistent lengths \
+        of [args] and [args_approxs]"
+  end;
+  let made_decision =
+    let closure_stack =
+      E.inlining_stats_closure_stack (E.note_entering_closure env
+          ~closure_id:closure_id_being_applied ~where:Inlining_decision)
+    in
+    Inlining_stats.record_decision ~closure_stack ~debuginfo:dbg
+  in
+  let original =
+    Flambda.Apply {
+      func = lhs_of_application;
+      args;
+      kind = Direct closure_id_being_applied;
+      dbg;
+      inline = inline_requested;
+    }
+  in
+  let original_r =
+    R.set_approx (R.seen_direct_application r) (A.value_unknown Other)
+  in
+  let max_level =
+    Clflags.Int_arg_helper.get ~key:(E.round env) !Clflags.max_inlining_depth
+  in
+  let inline_annotation =
+    (* Merge call site annotation and function annotation.
+       The call site annotation takes precedence *)
+    match (inline_requested : Lambda.inline_attribute) with
+    | Default_inline -> function_decl.inline
+    | Always_inline | Never_inline -> inline_requested
+  in
+  let always_inline =
+    match (inline_annotation : Lambda.inline_attribute) with
+    | Always_inline -> true
+    (* CR-someday mshinwell: consider whether there could be better
+       behaviour for stubs *)
+    | Never_inline | Default_inline -> false
+  in
+  let is_a_stub = function_decl.stub in
+  let num_params = List.length function_decl.params in
+  let only_use_of_function = false in
+  let raw_inlining_threshold = R.inlining_threshold r in
+  let max_inlining_threshold =
+    if E.at_toplevel env then
+      Inline_and_simplify_aux.initial_inlining_toplevel_threshold
+        ~round:(E.round env)
+    else
+      Inline_and_simplify_aux.initial_inlining_threshold ~round:(E.round env)
+  in
+  let unthrottled_inlining_threshold =
+    match raw_inlining_threshold with
+    | None -> max_inlining_threshold
+    | Some inlining_threshold -> inlining_threshold
+  in
+  let inlining_threshold =
+    T.min unthrottled_inlining_threshold max_inlining_threshold
+  in
+  let inlining_threshold_diff =
+    T.sub unthrottled_inlining_threshold inlining_threshold
+  in
+  let fun_var =
+    U.find_declaration_variable closure_id_being_applied function_decls
+  in
+  let recursive_functions =
+    lazy
+      (Find_recursive_functions.in_function_declarations function_decls
+         ~backend:(E.backend env))
+  in
+  let recursive =
+    lazy (Variable.Set.mem fun_var (Lazy.force recursive_functions))
+  in
+  let fun_cost : Inlining_cost.Threshold.t =
+    match (inline_annotation : Lambda.inline_attribute) with
+    | Never_inline -> Never_inline
+    | Always_inline | Default_inline ->
+      if always_inline
+        || is_a_stub
+        || (only_use_of_function && not (Lazy.force recursive))
+      then
+        inlining_threshold
+      else begin
+        Inlining_cost.can_try_inlining function_decl.body inlining_threshold
+          ~number_of_arguments:num_params
+          (* CR mshinwell: for the moment, this is None, since the
+             Inlining_cost code isn't checking sizes up to the max inlining
+             threshold---this seems to take too long. *)
+          ~size_from_approximation:None
+      end
+  in
+  let simpl =
+    if E.never_inline env then
+      (* This case only occurs when examining the body of a stub function
+         but not in the context of inlining said function.  As such, there
+         is nothing to do here (and no decision to report). *)
+      None
+    else if fun_cost = T.Never_inline && not function_decl.stub then
+      (* CR pchambart: should we also accept unconditionnal inline ?
+         It is some kind of user defined stub, but if we restrict to stub
+         we are certain that no abusive use of [@@inline] can blow things up *)
+      let reason : Inlining_stats_types.Decision.t =
+        match inlining_threshold with
+        | Never_inline ->
+          Function_prevented_from_inlining
+        | Can_inline_if_no_larger_than threshold ->
+          Function_obviously_too_large threshold
+      in
+      made_decision reason;
+      None
+    else
+      let remaining_inlining_threshold = fun_cost in
+      let r = R.set_inlining_threshold r (Some remaining_inlining_threshold) in
+      (* Try inlining if the function is non-recursive and not too far above
+         the threshold (or if the function is to be unconditionally
+         inlined). *)
+      (* CR mshinwell for pchambart: I don't understand why this was applying
+         inline_non_recursive to recursive functions. *)
+      if is_a_stub
+        || (E.inlining_level env < max_level
+            (* The classic heuristic completely disables inlining if the
+               function is not annotated as to be inlined. *)
+            && (always_inline || not !Clflags.classic_inlining)
+            && not (Lazy.force recursive))
+      then
+        let size_from_approximation =
+          match
+            Variable.Map.find fun_var (Lazy.force value_set_of_closures.size)
+          with
+          | size -> size
+          | exception Not_found ->
+            Misc.fatal_errorf "Approximation does not give a size for the \
+                function having fun_var %a.  value_set_of_closures: %a"
+              Variable.print fun_var
+              A.print_value_set_of_closures value_set_of_closures
+        in
+        inline_non_recursive env r ~function_decls ~lhs_of_application
+          ~closure_id_being_applied ~function_decl ~value_set_of_closures
+          ~made_decision ~only_use_of_function ~original
+          ~inline_requested ~always_inline ~args ~size_from_approximation
+          ~simplify
+      else if E.inlining_level env >= max_level then begin
+        made_decision (Can_inline_but_tried_nothing (Level_exceeded true));
+        None
+      end else if not !Clflags.classic_inlining && Lazy.force recursive then
+        inline_recursive env r ~max_level ~lhs_of_application ~function_decls
+          ~closure_id_being_applied ~function_decl ~value_set_of_closures
+          ~args ~args_approxs ~dbg ~simplify ~original ~made_decision
+      else begin
+        made_decision (Can_inline_but_tried_nothing (Level_exceeded false));
+        None
+      end
+  in
+  match simpl with
+  | None -> original, original_r
+  | Some (expr, r) ->
+    if E.inlining_level env = 0
+    then expr, R.set_inlining_threshold r raw_inlining_threshold
+    else expr, R.add_inlining_threshold r inlining_threshold_diff
+
+
+(* We do not inline inside stubs, which are always inlined at their call site.
+   Inlining inside the declaration of a stub could result in more code than
+   expected being inlined. *)
+(* CR mshinwell for pchambart: maybe we need an example here *)
+let should_inline_inside_declaration (decl : Flambda.function_declaration) =
+  not decl.stub

middle_end/inlining_decision.mli

@@ -0,0 +1,39 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* CR mshinwell: Add the new inlining heuristic documentation here. *)
+
+(** Try to inline a full application of a known function, guided by various
+    heuristics. *)
+val for_call_site
+   : env:Inline_and_simplify_aux.Env.t
+  -> r:Inline_and_simplify_aux.Result.t
+  -> function_decls:Flambda.function_declarations
+  -> lhs_of_application:Variable.t
+  -> closure_id_being_applied:Closure_id.t
+  -> function_decl:Flambda.function_declaration
+  -> value_set_of_closures:Simple_value_approx.value_set_of_closures
+  -> args:Variable.t list
+  -> args_approxs:Simple_value_approx.t list
+  -> dbg:Debuginfo.t
+  -> simplify:Inlining_decision_intf.simplify
+  -> inline_requested:Lambda.inline_attribute
+  -> Flambda.t * Inline_and_simplify_aux.Result.t
+
+(** When a function declaration is encountered by [for_call_site], the body
+    may be subject to inlining immediately, thus changing the declaration.
+    This function must return [true] for that to be able to happen. *)
+val should_inline_inside_declaration : Flambda.function_declaration -> bool

middle_end/inlining_decision_intf.mli

@@ -0,0 +1,47 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* CR-someday mshinwell: name of this source file could now be improved *)
+
+type 'a by_copying_function_body =
+     env:Inline_and_simplify_aux.Env.t
+  -> r:Inline_and_simplify_aux.Result.t
+  -> clos:Flambda.function_declarations
+  -> lfunc:Flambda.t
+  -> fun_id:Closure_id.t
+  -> func:Flambda.function_declaration
+  -> args:Flambda.t list
+  -> Flambda.t * Inline_and_simplify_aux.Result.t
+
+type 'a by_copying_function_declaration =
+     env:Inline_and_simplify_aux.Env.t
+  -> r:Inline_and_simplify_aux.Result.t
+  -> funct:Flambda.t
+  -> clos:Flambda.function_declarations
+  -> fun_id:Closure_id.t
+  -> func:Flambda.function_declaration
+  -> args_with_approxs:
+      (Flambda.t list) * (Simple_value_approx.t list)
+  -> invariant_params:Variable.Set.t
+  -> specialised_args:Variable.Set.t
+  -> dbg:Debuginfo.t
+  -> (Flambda.t * Inline_and_simplify_aux.Result.t) option
+
+type simplify =
+     Inline_and_simplify_aux.Env.t
+  -> Inline_and_simplify_aux.Result.t
+  -> Flambda.t
+  -> Flambda.t * Inline_and_simplify_aux.Result.t

middle_end/inlining_stats.ml

@@ -0,0 +1,161 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+let vim_trailer = "vim:fdm=expr:filetype=plain:\
+  foldexpr=getline(v\\:lnum)=~'^\\\\s*$'&&getline(v\\:lnum+1)=~'\\\\S'?'<1'\\:1"
+
+module Closure_stack = struct
+  type t
+    = (Closure_id.t * Inlining_stats_types.where_entering_closure) list
+
+  let create () = []
+
+  let _compare t1 t2 =
+    match t1, t2 with
+    | (id1, _)::_, (id2, _)::_ ->
+      let (_ : string) = Format.flush_str_formatter () in
+      let (id1 : string) =
+        Format.fprintf Format.str_formatter "%a" Closure_id.print id1;
+        Format.flush_str_formatter ()
+      in
+      let id2 =
+        Format.fprintf Format.str_formatter "%a" Closure_id.print id2;
+        Format.flush_str_formatter ()
+      in
+      String.compare id1 id2
+    | _ -> 0
+
+  let note_entering_closure t ~closure_id ~where =
+    if not !Clflags.inlining_stats then t
+    else t @ [closure_id, where]
+
+  let pop = function
+    | [] -> failwith "Closure_stack.pop on empty stack"
+    | hd::tl -> (fst hd), tl
+
+  let save t ~out_channel =
+    let print_elt (closure_id, where) ~last_one =
+      let current_unit = Compilation_unit.get_current_exn () in
+      let output =
+        if Closure_id.in_compilation_unit closure_id current_unit then
+          Closure_id.output
+        else
+          Closure_id.output_full
+      in
+      begin match (where : Inlining_stats_types.where_entering_closure) with
+        | Inline_by_copying_function_declaration closure_ids ->
+          let closure_ids = Closure_id.Set.remove closure_id closure_ids in
+          if Closure_id.Set.cardinal closure_ids < 1 then
+            Printf.fprintf out_channel "in copy of %a" output closure_id
+          else begin
+            Printf.fprintf out_channel "in copy of %a (and" output closure_id;
+            Closure_id.Set.iter (fun closure_id ->
+                Printf.fprintf out_channel " %a" output closure_id)
+              closure_ids;
+            Printf.fprintf out_channel ")"
+          end
+        | Transform_set_of_closures_expression ->
+          Printf.fprintf out_channel "decl of %a" output closure_id
+        | Inline_by_copying_function_body ->
+          Printf.fprintf out_channel "inlined body of %a" output closure_id
+        | Inlining_decision ->
+          Printf.fprintf out_channel "%a" output closure_id
+      end;
+      if not last_one then begin
+        match (where : Inlining_stats_types.where_entering_closure) with
+        | Inline_by_copying_function_declaration _
+        | Inline_by_copying_function_body ->
+          Printf.fprintf out_channel ": "
+        | Transform_set_of_closures_expression
+        | Inlining_decision -> Printf.fprintf out_channel " -> "
+      end
+    in
+    let rec loop = function
+      | [] -> Printf.fprintf out_channel "[]"
+      | [elt] -> print_elt elt ~last_one:true
+      | elt::elts ->
+        print_elt elt ~last_one:false;
+        loop elts
+    in
+    loop t
+end
+
+let time = ref 0
+
+module Line_number_then_time = struct
+  type t = Debuginfo.t * int
+
+  let compare_fst (((dbg1, t1) : t), _) (((dbg2, t2) : t), _) =
+    match compare dbg1.dinfo_line dbg2.dinfo_line with
+    | -1 -> -1
+    | 1 -> 1
+    | _ -> compare t1 t2
+
+  let create ~debuginfo ~time = debuginfo, time
+  let line_number t = (fst t).Debuginfo.dinfo_line
+end
+
+let decisions :
+  (Line_number_then_time.t
+      * (Closure_stack.t * Inlining_stats_types.Decision.t)) list
+    Closure_id.Tbl.t = Closure_id.Tbl.create 42
+
+let record_decision decision ~closure_stack ~debuginfo =
+  if !Clflags.inlining_stats then begin
+    let closure_id, closure_stack = Closure_stack.pop closure_stack in
+    let bucket =
+      match Closure_id.Tbl.find decisions closure_id with
+      | exception Not_found -> []
+      | bucket -> bucket
+    in
+    let key = Line_number_then_time.create ~debuginfo ~time:!time in
+    let data = closure_stack, decision in
+    (* The order here is important so that the "time rebasing" works
+       properly, below. *)
+    Closure_id.Tbl.replace decisions closure_id ((key, data) :: bucket);
+    incr time
+  end
+
+let really_save_then_forget_decisions ~output_prefix =
+  let out_channel = open_out (output_prefix ^ ".inlining") in
+  Closure_id.Tbl.iter (fun closure_id bucket ->
+      Printf.fprintf out_channel "%a\n" Closure_id.output closure_id;
+      let bucket =
+        let rebased_time = ref (-1) in
+        (* Rebase timestamps to start at zero within each bucket. *)
+        List.rev_map (fun (key, (closure_stack, decision)) ->
+            incr rebased_time;
+            key, (!rebased_time, closure_stack, decision))
+          bucket
+      in
+      let bucket = List.sort Line_number_then_time.compare_fst bucket in
+      List.iter (fun (key, (time, closure_stack, decision)) ->
+          let line = Line_number_then_time.line_number key in
+          Printf.fprintf out_channel "  %5d: (%5d) " line time;
+          Closure_stack.save closure_stack ~out_channel;
+          Printf.fprintf out_channel ": %s\n"
+            (Inlining_stats_types.Decision.to_string decision))
+        bucket;
+      Printf.fprintf out_channel "\n") decisions;
+  Printf.fprintf out_channel "# %s\n" vim_trailer;
+  close_out out_channel;
+  Closure_id.Tbl.clear decisions;
+  time := 0
+
+let save_then_forget_decisions ~output_prefix =
+  if !Clflags.inlining_stats then begin
+    really_save_then_forget_decisions ~output_prefix
+  end

middle_end/inlining_stats.mli

@@ -0,0 +1,35 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Closure_stack : sig
+  type t
+
+  val create : unit -> t
+
+  val note_entering_closure
+     : t
+    -> closure_id:Closure_id.t
+    -> where:Inlining_stats_types.where_entering_closure
+    -> t
+end
+
+val record_decision
+   : Inlining_stats_types.Decision.t
+  -> closure_stack:Closure_stack.t
+  -> debuginfo:Debuginfo.t
+  -> unit
+
+val save_then_forget_decisions : output_prefix:string -> unit

middle_end/inlining_stats_types.ml

@@ -0,0 +1,105 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+module Wsb = Inlining_cost.Whether_sufficient_benefit
+
+module Tried_unrolling = struct
+  type t =
+    | Tried_unrolling of bool
+
+  let to_string = function
+    | Tried_unrolling true -> "tried unrolling"
+    | Tried_unrolling false -> "did not try unrolling"
+end
+
+module Copying_body = struct
+  type t =
+    | Unconditionally
+    | Decl_local_to_application
+    | Evaluated of Wsb.t
+    | Evaluated_unspecialized
+    | Stub
+
+  let to_string = function
+    | Unconditionally -> "unconditionally"
+    | Decl_local_to_application -> "decl local to application expression"
+    | Evaluated wsb -> Wsb.to_string wsb
+    | Evaluated_unspecialized -> "too large without specialized arguments"
+    | Stub -> "stub"
+end
+
+module Inlined = struct
+  type t =
+    | Copying_body of Copying_body.t
+    | Copying_body_with_subfunctions of Copying_body.t
+    | Unrolled of Wsb.t
+    | Copying_decl of Tried_unrolling.t * Wsb.t
+
+  let to_string = function
+    | Copying_body cb ->
+      Printf.sprintf "copying body (%s)" (Copying_body.to_string cb)
+    | Copying_body_with_subfunctions cb ->
+      Printf.sprintf "copying body using subfunctions (%s)" (Copying_body.to_string cb)
+    | Unrolled wsb ->
+      Printf.sprintf "unrolled (%s)" (Wsb.to_string wsb)
+    | Copying_decl (tried, wsb) ->
+      Printf.sprintf "copying decl (%s, %s)"
+        (Tried_unrolling.to_string tried) (Wsb.to_string wsb)
+end
+
+module Decision = struct
+
+  type level_exceeded =
+    | Level_exceeded of bool
+
+  type t =
+    | Function_obviously_too_large of int
+    | Function_prevented_from_inlining
+    | Inlined of Inlined.t
+    | Tried of Inlined.t
+    | Did_not_try_copying_decl of Tried_unrolling.t
+    | Can_inline_but_tried_nothing of level_exceeded
+
+  let to_string = function
+    | Function_obviously_too_large threshold ->
+      Printf.sprintf "function obviously too large (threshold: %i)"
+        threshold
+    | Function_prevented_from_inlining -> "function prevented from inlining"
+    | Inlined inlined ->
+      Printf.sprintf "inlined (%s)" (Inlined.to_string inlined)
+    | Tried inlined ->
+      Printf.sprintf "tried but failed (%s)" (Inlined.to_string inlined)
+    | Did_not_try_copying_decl tried ->
+      Printf.sprintf "did not try copying decl (%s)"
+        (Tried_unrolling.to_string tried)
+    | Can_inline_but_tried_nothing (Level_exceeded b) ->
+        if b then
+          "can inline, but tried nothing, too deep into inlining"
+        else
+          "can inline, but tried nothing"
+end
+
+type where_entering_closure =
+  | Transform_set_of_closures_expression
+  | Inline_by_copying_function_body
+  | Inline_by_copying_function_declaration of Closure_id.Set.t
+  | Inlining_decision
+
+let char_of_where = function
+  | Transform_set_of_closures_expression -> 'T'
+  | Inline_by_copying_function_body -> 'B'
+  | Inline_by_copying_function_declaration _ -> 'D'
+  | Inlining_decision -> 'I'

middle_end/inlining_stats_types.mli

@@ -0,0 +1,69 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Types used for producing statistics about inlining. *)
+
+module Tried_unrolling : sig
+  type t =
+    | Tried_unrolling of bool
+
+  val to_string : t -> string
+end
+
+module Copying_body : sig
+  type t =
+    | Unconditionally
+    | Decl_local_to_application
+    | Evaluated of Inlining_cost.Whether_sufficient_benefit.t
+    | Evaluated_unspecialized
+    | Stub
+
+  val to_string : t -> string
+end
+
+module Inlined : sig
+  type t =
+    | Copying_body of Copying_body.t
+    | Copying_body_with_subfunctions of Copying_body.t
+    | Unrolled of Inlining_cost.Whether_sufficient_benefit.t
+    | Copying_decl of
+        Tried_unrolling.t * Inlining_cost.Whether_sufficient_benefit.t
+
+  val to_string : t -> string
+end
+
+module Decision : sig
+  type level_exceeded =
+    | Level_exceeded of bool
+
+  type t =
+    | Function_obviously_too_large of int
+    | Function_prevented_from_inlining
+    | Inlined of Inlined.t
+    | Tried of Inlined.t
+    | Did_not_try_copying_decl of Tried_unrolling.t
+    | Can_inline_but_tried_nothing of level_exceeded
+
+  val to_string : t -> string
+end
+
+type where_entering_closure =
+  | Transform_set_of_closures_expression
+  | Inline_by_copying_function_body
+  | Inline_by_copying_function_declaration of Closure_id.Set.t
+  | Inlining_decision
+
+val char_of_where : where_entering_closure -> char

middle_end/inlining_transforms.ml

@@ -0,0 +1,332 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+module A = Simple_value_approx
+module B = Inlining_cost.Benefit
+module E = Inline_and_simplify_aux.Env
+module R = Inline_and_simplify_aux.Result
+
+let new_var name =
+  Variable.create name
+    ~current_compilation_unit:(Compilation_unit.get_current_exn ())
+
+let which_function_parameters_can_we_specialise ~params ~args
+      ~args_approxs ~(invariant_params:Variable.Set.t Variable.Map.t lazy_t)
+      ~specialised_args =
+  assert (List.length params = List.length args);
+  assert (List.length args = List.length args_approxs);
+  List.fold_right2 (fun (var, arg) approx
+    (worth_specialising_args, spec_args, args, args_decl) ->
+      let spec_args =
+        if Variable.Map.mem var (Lazy.force invariant_params) ||
+           Variable.Set.mem var specialised_args
+        then
+          Variable.Map.add var arg spec_args
+        else
+          spec_args
+      in
+      let worth_specialising_args =
+        if Simple_value_approx.useful approx
+          && Variable.Map.mem var (Lazy.force invariant_params)
+        then
+          Variable.Set.add var worth_specialising_args
+        else
+          worth_specialising_args
+      in
+      worth_specialising_args, spec_args, arg :: args, args_decl)
+    (List.combine params args) args_approxs
+    (Variable.Set.empty, Variable.Map.empty, [], [])
+
+(** Fold over all variables bound by the given closure, which is bound to the
+    variable [lhs_of_application], and corresponds to the given
+    [function_decls].  Each variable bound by the closure is passed to the
+    user-specified function as an [Flambda.named] value that projects the
+    variable from its closure. *)
+let fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied
+      ~lhs_of_application ~function_decls ~init ~f =
+  Variable.Set.fold (fun var acc ->
+      let expr : Flambda.named =
+        Project_var {
+          closure = lhs_of_application;
+          closure_id = closure_id_being_applied;
+          var = Var_within_closure.wrap var;
+        }
+      in
+      f ~acc ~var ~expr)
+    (Flambda_utils.variables_bound_by_the_closure closure_id_being_applied
+      function_decls)
+    init
+
+let set_inline_attribute_on_all_apply body inline =
+  Flambda_iterators.map_toplevel_expr (function
+      | Apply apply -> Apply { apply with inline }
+      | expr -> expr)
+    body
+
+(** Assign fresh names for a function's parameters and rewrite the body to
+    use these new names. *)
+let copy_of_function's_body_with_freshened_params env
+      ~(function_decl : Flambda.function_declaration) =
+  let params = function_decl.params in
+  (* We cannot avoid the substitution in the case where we are inlining
+     inside the function itself.  This can happen in two ways: either
+     (a) we are inlining the function itself directly inside its declaration;
+     or (b) we are inlining the function into an already-inlined copy.
+     For (a) we cannot short-cut the substitution by freshening since the
+     original [params] may still be referenced; for (b) we cannot do it
+     either since the freshening may already be renaming the parameters for
+     the first inlining of the function. *)
+  if E.does_not_bind env params
+    && E.does_not_freshen env params
+  then
+    env, params, function_decl.body
+  else
+    let freshened_params = List.map (fun var -> Variable.rename var) params in
+    let subst = Variable.Map.of_list (List.combine params freshened_params) in
+    let body = Flambda_utils.toplevel_substitution subst function_decl.body in
+    env, freshened_params, body
+
+(* CR mshinwell: Add a note somewhere to explain why "bound by the closure"
+   does not include the function identifiers for other functions in the same
+   set of closures. *)
+
+(** Inline a function by copying its body into a context where it becomes
+    closed.  That is to say, we bind the free variables of the body
+    (= "variables bound by the closure"), and any function identifiers
+    introduced by the corresponding set of closures. *)
+let inline_by_copying_function_body ~env ~r ~function_decls ~lhs_of_application
+      ~(inline_requested : Lambda.inline_attribute)
+      ~closure_id_being_applied
+      ~(function_decl : Flambda.function_declaration) ~args ~simplify =
+  assert (E.mem env lhs_of_application);
+  assert (List.for_all (E.mem env) args);
+  let r = R.map_benefit r B.remove_call in
+  let env =
+    (* Don't allow the inlining level to inhibit inlining of stubs (e.g.
+       wrappers created by [Unbox_closures]). *)
+    if function_decl.stub then env
+    else E.inlining_level_up env
+  in
+  let env, freshened_params, body =
+    copy_of_function's_body_with_freshened_params env ~function_decl
+  in
+  let body =
+    if function_decl.stub && inline_requested <> Lambda.Default_inline then
+      (* When the function inlined function is a stub, the annotation
+         is reported to the function applications inside the stub.
+         This allows to report the annotation to the application the
+         original programmer really intended: the stub is not visible
+         in the source. *)
+      set_inline_attribute_on_all_apply body inline_requested
+    else
+      body
+  in
+  let bindings_for_params_to_args =
+    (* Bind the function's parameters to the arguments from the call site. *)
+    let args = List.map (fun arg -> Flambda.Expr (Var arg)) args in
+    Flambda_utils.bind ~body ~bindings:(List.combine freshened_params args)
+  in
+  (* Add bindings for the variables bound by the closure. *)
+  let bindings_for_vars_bound_by_closure_and_params_to_args =
+    fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied
+      ~lhs_of_application ~function_decls ~init:bindings_for_params_to_args
+      ~f:(fun ~acc:body ~var ~expr -> Flambda.create_let var expr body)
+  in
+  (* CR mshinwell: How does this not add a variable that points to the
+     function being applied itself?  Presumably it shouldn't do that. *)
+  (* Add bindings for variables corresponding to the functions introduced by
+     the whole set of closures.  Each such variable will be bound to a closure;
+     each such closure is in turn produced by moving from the closure being
+     applied to another closure in the same set.
+  *)
+  let expr =
+    Variable.Map.fold (fun another_closure_in_the_same_set _ expr ->
+        Flambda.create_let another_closure_in_the_same_set
+          (Move_within_set_of_closures {
+            closure = lhs_of_application;
+            start_from = closure_id_being_applied;
+            move_to = Closure_id.wrap another_closure_in_the_same_set;
+          })
+          expr)
+      function_decls.Flambda.funs
+      bindings_for_vars_bound_by_closure_and_params_to_args
+  in
+  let env =
+    E.note_entering_closure env ~closure_id:closure_id_being_applied
+      ~where:Inline_by_copying_function_body
+  in
+  simplify (E.activate_freshening env) r expr
+
+let inline_by_copying_function_declaration ~env ~r
+    ~(function_decls : Flambda.function_declarations)
+    ~lhs_of_application ~closure_id_being_applied
+    ~(function_decl : Flambda.function_declaration)
+    ~args ~args_approxs ~(invariant_params:Variable.Set.t Variable.Map.t lazy_t)
+    ~(specialised_args:Variable.t Variable.Map.t)
+    ~dbg ~simplify =
+  let specialised_args_set = Variable.Map.keys specialised_args in
+  let worth_specialising_args, specialisable_args, args, args_decl =
+    which_function_parameters_can_we_specialise
+      ~params:function_decl.params ~args ~args_approxs
+      ~invariant_params
+      ~specialised_args:specialised_args_set
+  in
+  (* Arguments of functions that are not directly called but are
+     aliased to arguments of a directly called one may need to be
+     marked as specialiased. *)
+  let specialisable_args_with_aliases =
+    Variable.Map.fold (fun arg outside_var map ->
+        match Variable.Map.find arg (Lazy.force invariant_params) with
+        | exception Not_found -> map
+        | set ->
+            Variable.Set.fold (fun alias map ->
+                Variable.Map.add alias outside_var map)
+              set map)
+      specialisable_args specialisable_args
+  in
+  (* The other closures from the same set of closures may have
+     specialised arguments. Those refer to variables that may not be
+     bound anymore in the current environment. The only allowed
+     remaining specialised arguments after duplicating a function are
+     those that either comes from the free variables of set of
+     closures or the arguments of the closure being applied (and
+     propagated transitively to other functions). This is ensured by
+     the fact that no closure not directly required by the closure
+     being applied are kept in the set. If an argument of an other
+     function of the set does not come from the closure being applied
+     then, that function cannot be applied (unreachable from the one
+     being aplied).
+
+     For specialised arguments of other function to reference a valid
+     value, they need to be rewritten accordingly to the ones of the
+     closure being applied. *)
+  let specialisable_renaming =
+    Variable.Map.fold (fun param outside_var map ->
+        match Variable.Map.find param specialised_args with
+        | exception Not_found ->
+          (* Newly specialised argument: no other function argument
+             may need renaming for that one *)
+          map
+        | original_outside_var ->
+          Variable.Map.add original_outside_var outside_var map)
+      specialisable_args_with_aliases Variable.Map.empty
+  in
+  if Variable.Set.subset worth_specialising_args specialised_args_set
+  then
+    (* Don't duplicate the function definition if we would make its
+       specialisation information worse.  (Note that this judgement is made
+       based only on those arguments found to be invariant with known-useful
+       approximations, rather than on all invariant arguments.) *)
+    None
+  else
+    let env =
+      if function_decl.stub then env
+      else E.inlining_level_up env
+    in
+    let set_of_closures_var = new_var "dup_set_of_closures" in
+    (* The free variable map for the duplicated declaration(s) maps the
+       "internal" names used within the function bodies to fresh names,
+       which in turn are bound to projections from the set of closures being
+       copied.  We add these bindings using [Let] around the new
+       set-of-closures declaration. *)
+    let free_vars, free_vars_for_lets =
+      fold_over_projections_of_vars_bound_by_closure ~closure_id_being_applied
+        ~lhs_of_application ~function_decls ~init:(Variable.Map.empty, [])
+        ~f:(fun ~acc:(map, for_lets) ~var:internal_var ~expr ->
+          let from_closure = new_var "from_closure" in
+          Variable.Map.add internal_var from_closure map,
+            (from_closure, expr)::for_lets)
+    in
+    let required_functions =
+      Flambda_utils.closures_required_by_entry_point ~backend:(E.backend env)
+        ~entry_point:closure_id_being_applied
+        function_decls
+    in
+    let funs =
+      Variable.Map.filter (fun func _ ->
+          Variable.Set.mem func required_functions)
+        function_decls.funs
+    in
+    let function_decls =
+      Flambda.update_function_declarations ~funs function_decls
+    in
+    let all_functions_parameters =
+      Flambda_utils.all_functions_parameters function_decls
+    in
+    let specialisable_args =
+      Variable.Map.merge (fun param v1 v2 ->
+          match v1, v2 with
+          | None, None -> None
+          | Some v, _ -> Some v
+          | None, Some v ->
+            if Variable.Set.mem param all_functions_parameters then
+              match Variable.Map.find v specialisable_renaming with
+              | exception Not_found ->
+                Misc.fatal_errorf
+                  "Missing renaming for specialised argument of a function \
+                    being duplicated but not directly applied: %a -> %a"
+                  Variable.print param Variable.print v
+              | argument_from_the_current_application ->
+                Some argument_from_the_current_application
+            else
+              None)
+        specialisable_args_with_aliases specialised_args
+    in
+    let set_of_closures =
+      (* This is the new set of closures, with more precise specialisation
+         information than the one being copied. *)
+      Flambda.create_set_of_closures ~function_decls ~free_vars
+        ~specialised_args:specialisable_args
+    in
+    (* Generate a copy of the function application, including the function
+       declaration(s), but with variables (not yet bound) in place of the
+       arguments. *)
+    let duplicated_application : Flambda.t =
+      let project_closure : Flambda.project_closure =
+        { set_of_closures = set_of_closures_var;
+          closure_id = closure_id_being_applied;
+        }
+      in
+      let func = new_var "dup_func" in
+      let body : Flambda.t =
+        Flambda.create_let set_of_closures_var
+          (Set_of_closures set_of_closures)
+          (Flambda.create_let func (Project_closure project_closure)
+            (Apply {
+              func;
+              args;
+              kind = Direct closure_id_being_applied;
+              dbg;
+              inline = function_decl.inline;
+            }))
+      in
+      Flambda_utils.bind ~bindings:free_vars_for_lets ~body
+    in
+    (* Now bind the variables that will hold the arguments from the original
+       application. *)
+    let expr : Flambda.t =
+      Flambda_utils.bind ~body:duplicated_application ~bindings:args_decl
+    in
+    let env =
+      let closure_ids =
+        Closure_id.Set.of_list (
+          List.map Closure_id.wrap
+            (Variable.Set.elements (Variable.Map.keys function_decls.funs)))
+      in
+      E.note_entering_closure env ~closure_id:closure_id_being_applied
+        ~where:(Inline_by_copying_function_declaration closure_ids)
+    in
+    Some (simplify (E.activate_freshening env) r expr)

middle_end/inlining_transforms.mli

@@ -0,0 +1,97 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Source code transformations used during inlining. *)
+
+(** Inline a function by substituting its body (which may be subject to
+    further transformation) at a call site.  The function's declaration is
+    not copied.
+ 
+    This transformation is used when:
+    - inlining a call to a non-recursive function;
+    - inlining a call, within a recursive or mutually-recursive function, to
+      the same or another function being defined simultaneously ("unrolling").
+      The maximum depth of unrolling is bounded (see [E.unrolling_allowed]).
+ 
+    In both cases, the body of the function is copied, within a sequence of
+    [let]s that bind the function parameters, the variables "bound by the
+    closure" (see flambda.mli), and any function identifiers introduced by the
+    set of closures.  These stages are delimited below by comments.
+ 
+    As an example, suppose we are inlining the following function:
+ 
+     let f x = x + y
+     ...
+     let p = f, f in
+     (fst p) 42
+ 
+    The call site [ (fst p) 42] will be transformed to:
+ 
+      let clos_id = fst p in  (* must eventually yield a closure *)
+      let y = <access to [y] in [clos_id]> in
+      let x' = 42 in
+      let x = x' in
+      x + y
+ 
+    When unrolling a recursive function we rename the arguments to the
+    recursive call in order to avoid clashes with existing bindings.  For
+    example, suppose we are inlining the following call to [f], which lies
+    within its own declaration:
+ 
+      let rec f x y =
+        f (fst x) (y + snd x)
+ 
+    This will be transformed to:
+ 
+      let rec f x y =
+        let clos_id = f in (* not used this time, since [f] has no free vars *)
+        let x' = fst x in
+        let y' = y + snd x in
+        f (fst x') (y' + snd x')  (* body of [f] with parameters freshened *)
+*)
+val inline_by_copying_function_body
+   : env:Inline_and_simplify_aux.Env.t
+  -> r:Inline_and_simplify_aux.Result.t
+  -> function_decls:Flambda.function_declarations
+  -> lhs_of_application:Variable.t
+  -> inline_requested:Lambda.inline_attribute
+  -> closure_id_being_applied:Closure_id.t
+  -> function_decl:Flambda.function_declaration
+  -> args:Variable.t list
+  -> simplify:Inlining_decision_intf.simplify
+  -> Flambda.t * Inline_and_simplify_aux.Result.t
+
+(** Inlining of recursive function(s) yields a copy of the functions'
+    definitions (not just their bodies, unlike the non-recursive case) and
+    a direct application of the new body.
+    Note: the function really does need to be recursive (but possibly only via
+    some mutual recursion) to end up in here; a simultaneous binding [that is
+    non-recursive] is not sufficient.
+*)
+val inline_by_copying_function_declaration
+   : env:Inline_and_simplify_aux.Env.t
+  -> r:Inline_and_simplify_aux.Result.t
+  -> function_decls:Flambda.function_declarations
+  -> lhs_of_application:Variable.t
+  -> closure_id_being_applied:Closure_id.t
+  -> function_decl:Flambda.function_declaration
+  -> args:Variable.t list
+  -> args_approxs:Simple_value_approx.t list
+  -> invariant_params:Variable.Set.t Variable.Map.t lazy_t
+  -> specialised_args:Variable.t Variable.Map.t
+  -> dbg:Debuginfo.t
+  -> simplify:Inlining_decision_intf.simplify
+  -> (Flambda.t * Inline_and_simplify_aux.Result.t) option

middle_end/invariant_params.ml

@@ -0,0 +1,395 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* CR-someday pchambart to pchambart: in fact partial application doesn't
+   work because there are no 'known' partial application left: they are
+   converted to applications new partial function declaration.
+   That can be improved (and many other cases) by keeping track of aliases in
+   closure of functions. *)
+
+(* A parameter [x] of the function [f] is considered as unchanging if during
+   an 'external' (call from outside the set of closures) call of [f], every
+   recursive call of [f] all the instances of [x] are aliased to the original
+   one.
+
+   This function computes an underapproximation of that set by computing the
+   flow of parameters between the different function of the set of closures.
+   We will write (f, x) <- (g, y) to denote that the parameter [x] of the
+   function [f] can be an alias of the parameter [y] of the function [g].
+   (f, x) <- Anything denote that unknown values can flow to [x].
+   The '<-' relation is transitive.
+
+   [x] is not unchanging if either
+      (f, x) <- Anything
+   or (f, x) <- (f, y) with x != y
+
+   Notice that having (f, x) <- (g, a) and (f, x) <- (g, b) does not make
+   x not unchanging. This is because (g, a) and (g, b) represent necessarily
+   different values only if g is the externaly called function. If some
+   value where created during the execution of the function that could
+   flow to (g, a), then (g, a) <- Anything, so (f, x) <- Anything.
+
+ *)
+
+(* This is computed in two steps:
+   * accumulate the atomic <- relations
+   * compute the transitive closure
+
+   We record [(f, x) <- Argument (g, y)] when the function g calls f and
+   the y parameter of g is used as argument for the x parameter of f. For
+   instance in
+
+     let rec f x = ...
+     and g y = f x
+
+   We record [(f, x) <- Anything] when some unknown values can flow to a the
+   [y] parameter.
+
+     let rec f x = f 1
+
+   We record also [(f, x) <- Anything] if [f] could escape. This is over
+   approximated by considering that a function escape when its variable is used
+   for something else than an application:
+
+     let rec f x = (f, f)
+
+
+  The <- relation is represented by the type
+
+     t Variable.Pair.Map.t
+
+  if [Variable.Pair.Set.mem (g, y) s] and
+  [Argument s = Variable.Pair.Map.find (f, x) relation]
+  then (f, x) <- (g, y) is in the relation.
+
+*)
+
+type t =
+  | Anything
+  | Arguments of Variable.Pair.Set.t
+
+let _print ppf = function
+  | Anything -> Format.fprintf ppf "Anything"
+  | Arguments args ->
+      Format.fprintf ppf "Arguments: @[<hv>%a@]"
+        Variable.Pair.Set.print args
+
+let transitive_closure state =
+  let union s1 s2 =
+    match s1, s2 with
+    | Anything, _ | _, Anything -> Anything
+    | Arguments s1, Arguments s2 -> Arguments (Variable.Pair.Set.union s1 s2)
+  in
+  let equal s1 s2 =
+    match s1, s2 with
+    | Anything, Arguments _ | Arguments _, Anything -> false
+    | Anything, Anything -> true
+    | Arguments s1, Arguments s2 -> Variable.Pair.Set.equal s1 s2
+  in
+  let update arg state =
+    let original_set =
+      try Variable.Pair.Map.find arg state with
+      | Not_found -> Arguments Variable.Pair.Set.empty
+    in
+    match original_set with
+    | Anything -> state
+    | Arguments arguments ->
+        let set =
+          Variable.Pair.Set.fold
+            (fun orig acc->
+               let set =
+                 try Variable.Pair.Map.find orig state with
+                 | Not_found -> Arguments Variable.Pair.Set.empty in
+               union set acc)
+            arguments original_set
+        in
+        Variable.Pair.Map.add arg set state
+  in
+  let once state =
+    Variable.Pair.Map.fold (fun arg _ state -> update arg state) state state
+  in
+  let rec fp state =
+    let state' = once state in
+    if Variable.Pair.Map.equal equal state state'
+    then state
+    else fp state'
+  in
+  fp state
+
+(* CR-soon pchambart: to move to Flambda_utils and document
+   mshinwell: I think this calculation is basically the same as
+   [Flambda_utils.fun_vars_referenced_in_decls], so we should try
+   to share code.  However let's defer until after 4.03.  (And note CR
+   below.)
+*)
+(* Finds variables that represent the functions.
+   In a construction like:
+     let f x =
+       let g = Symbol f_closure in
+       ..
+   the variable g is bound to the symbol f_closure which
+   is the current closure.
+   The result of [function_variable_alias] will contain
+   the association [g -> f]
+*)
+let function_variable_alias
+    (function_decls : Flambda.function_declarations)
+    ~backend =
+  let fun_vars = Variable.Map.keys function_decls.funs in
+  let symbols_to_fun_vars =
+    let module Backend = (val backend : Backend_intf.S) in
+    Variable.Set.fold (fun fun_var symbols_to_fun_vars ->
+        let closure_id = Closure_id.wrap fun_var in
+        let symbol = Backend.closure_symbol closure_id in
+        Symbol.Map.add symbol fun_var symbols_to_fun_vars)
+      fun_vars
+      Symbol.Map.empty
+  in
+  let fun_var_bindings = ref Variable.Map.empty in
+  Variable.Map.iter (fun _ ( function_decl : Flambda.function_declaration ) ->
+      Flambda_iterators.iter_all_toplevel_immutable_let_and_let_rec_bindings
+        ~f:(fun var named ->
+           (* CR-soon mshinwell: consider having the body passed to this
+              function and using fv calculation instead of used_variables.
+              Need to be careful of "let rec" *)
+           match named with
+           | Symbol sym ->
+             begin match Symbol.Map.find sym symbols_to_fun_vars with
+             | exception Not_found -> ()
+             | fun_var ->
+               fun_var_bindings :=
+                 Variable.Map.add var fun_var !fun_var_bindings
+             end
+           | _ -> ())
+        function_decl.body)
+    function_decls.funs;
+  !fun_var_bindings
+
+let invariant_params_in_recursion (decls : Flambda.function_declarations)
+      ~backend =
+  let function_variable_alias = function_variable_alias ~backend decls in
+  let escaping_functions = Variable.Tbl.create 13 in
+  let relation = ref Variable.Pair.Map.empty in
+  let param_indexes_by_fun_vars =
+    Variable.Map.map (fun (decl : Flambda.function_declaration) ->
+        Array.of_list decl.params)
+      decls.funs
+  in
+  let link ~callee ~callee_arg ~caller ~caller_arg =
+    let kind =
+      try Variable.Pair.Map.find (callee, callee_arg) !relation with
+      | Not_found -> Arguments Variable.Pair.Set.empty
+    in
+    match kind with
+    | Anything -> ()
+    | Arguments set ->
+      relation :=
+        Variable.Pair.Map.add (callee, callee_arg)
+          (Arguments (Variable.Pair.Set.add (caller, caller_arg) set))
+          !relation
+  in
+  let argument_may_be_anything ~callee ~callee_arg =
+    relation := Variable.Pair.Map.add (callee, callee_arg) Anything !relation
+  in
+  let find_callee_arg ~callee ~callee_pos =
+    match Variable.Map.find callee param_indexes_by_fun_vars with
+    | exception Not_found -> None (* not a recursive call *)
+    | arr ->
+      (* Ignore overapplied parameters: they are applied to a different
+         function. *)
+      if callee_pos < Array.length arr then Some arr.(callee_pos)
+      else None
+  in
+  (* If the called closure is in the current set of closures, record the
+     relation (callee, callee_arg) <- (caller, caller_arg) *)
+  let check_argument ~caller ~callee ~callee_pos ~caller_arg =
+    match find_callee_arg ~callee ~callee_pos with
+    | None -> () (* not a recursive call *)
+    | Some callee_arg ->
+      match Variable.Map.find caller decls.funs with
+      | exception Not_found ->
+        assert false
+      | { params } ->
+        (* We only track dataflow for parameters of functions, not
+           arbitrary variables. *)
+        if List.mem caller_arg params then
+          link ~caller ~caller_arg ~callee ~callee_arg
+        else
+          argument_may_be_anything ~callee ~callee_arg
+  in
+  let test_escape var =
+    let fun_var =
+      match Variable.Map.find var function_variable_alias with
+      | exception Not_found -> var
+      | fun_var -> fun_var
+    in
+    if Variable.Map.mem fun_var decls.funs
+    then Variable.Tbl.add escaping_functions fun_var ()
+  in
+  let arity ~callee =
+    match Variable.Map.find callee decls.funs with
+    | exception Not_found -> 0
+    | func -> Flambda_utils.function_arity func
+  in
+  let check_expr ~caller (expr : Flambda.t) =
+    match expr with
+    | Apply { func; args } ->
+      let callee =
+        match Variable.Map.find func function_variable_alias with
+        | exception Not_found -> func
+        | callee -> callee
+      in
+      let num_args = List.length args in
+      for callee_pos = num_args to (arity ~callee) - 1 do
+        (* If a function is partially applied, consider all missing
+           arguments as "anything". *)
+        match find_callee_arg ~callee ~callee_pos with
+        | None -> ()
+        | Some callee_arg -> argument_may_be_anything ~callee ~callee_arg
+      done;
+      List.iteri (fun callee_pos caller_arg ->
+          check_argument ~caller ~callee ~callee_pos ~caller_arg)
+        args
+    | _ -> ()
+  in
+  Variable.Map.iter (fun caller (decl : Flambda.function_declaration) ->
+      Flambda_iterators.iter (check_expr ~caller)
+        (fun (_ : Flambda.named) -> ())
+        decl.body;
+      Variable.Set.iter test_escape
+        (* CR-soon mshinwell: we should avoid recomputing this, cache in
+           [function_declaration].  See also comment on
+           [only_via_symbols] in [Flambda_utils]. *)
+        (Flambda.used_variables ~ignore_uses_as_callee:() decl.body))
+    decls.funs;
+  Variable.Map.iter (fun func_var
+        ({ params } : Flambda.function_declaration) ->
+      if Variable.Tbl.mem escaping_functions func_var then begin
+        List.iter (fun param ->
+            argument_may_be_anything ~callee:func_var ~callee_arg:param)
+          params
+      end)
+    decls.funs;
+  let result = transitive_closure !relation in
+  let not_unchanging =
+    Variable.Pair.Map.fold (fun (func, var) set not_unchanging ->
+        match set with
+        | Anything -> Variable.Set.add var not_unchanging
+        | Arguments set ->
+          if Variable.Pair.Set.exists (fun (func', var') ->
+              Variable.equal func func' && not (Variable.equal var var'))
+              set
+          then Variable.Set.add var not_unchanging
+          else not_unchanging)
+      result Variable.Set.empty
+  in
+  let params = Variable.Map.fold (fun _
+        ({ params } : Flambda.function_declaration) set ->
+      Variable.Set.union (Variable.Set.of_list params) set)
+    decls.funs Variable.Set.empty
+  in
+  let unchanging = Variable.Set.diff params not_unchanging in
+  let aliased_to =
+    Variable.Pair.Map.fold (fun (_, var) set aliases ->
+        match set with
+        | Arguments set
+          when Variable.Set.mem var unchanging ->
+            Variable.Pair.Set.fold (fun (_, caller_args) aliases ->
+                if Variable.Set.mem caller_args unchanging then
+                  let alias_set =
+                    match Variable.Map.find caller_args aliases with
+                    | exception Not_found ->
+                      Variable.Set.singleton var
+                    | alias_set ->
+                      Variable.Set.add var alias_set
+                  in
+                  Variable.Map.add caller_args alias_set aliases
+                else
+                  aliases)
+              set aliases
+        | Anything | Arguments _ -> aliases)
+      result Variable.Map.empty
+  in
+  (* We complete the set of aliases such that there does not miss any
+     unchanging param *)
+  Variable.Map.of_set (fun var ->
+      match Variable.Map.find var aliased_to with
+      | exception Not_found -> Variable.Set.empty
+      | set -> set)
+    unchanging
+
+type argument =
+  | Used
+  | Argument of Variable.t
+
+let unused_arguments (decls : Flambda.function_declarations) : Variable.Set.t =
+  let used_variables = Variable.Tbl.create 42 in
+  let used_variable var = Variable.Tbl.add used_variables var () in
+  let param_indexes_by_fun_vars =
+    Variable.Map.fold (fun var (decl : Flambda.function_declaration) map ->
+        let cid = Closure_id.wrap var in
+        Closure_id.Map.add cid (Array.of_list decl.params) map)
+      decls.funs Closure_id.Map.empty
+  in
+  let find_callee_arg ~callee ~callee_pos ~application_expr =
+    match Closure_id.Map.find callee param_indexes_by_fun_vars with
+    | exception Not_found -> Used (* not a recursive call *)
+    | arr ->
+      (* Direct calls don't have overapplication *)
+      if callee_pos >= Array.length arr then begin
+        Misc.fatal_errorf "Invariant_params.unused_arguments: direct calls \
+            may not have overapplication: callee %a, application expr: %a, \
+            function decls: %a"
+          Closure_id.print callee
+          Flambda.print application_expr
+          Flambda.print_function_declarations decls
+      end;
+      Argument arr.(callee_pos)
+  in
+  let check_expr (expr : Flambda.t) =
+    match expr with
+    | Apply { func; args; kind = Direct callee } ->
+      used_variable func;
+      List.iteri (fun callee_pos arg ->
+          match
+            find_callee_arg ~callee ~callee_pos ~application_expr:expr
+          with
+          | Used -> used_variable arg
+          | Argument param ->
+            if not (Variable.equal arg param) then used_variable arg)
+        args
+    | Apply { func; args; kind = Indirect; _ } ->
+      used_variable func;
+      List.iter used_variable args
+    | _ -> ()
+  in
+  Variable.Map.iter (fun _caller (decl : Flambda.function_declaration) ->
+      Flambda_iterators.iter check_expr (fun (_ : Flambda.named) -> ())
+        decl.body;
+      Variable.Set.iter used_variable
+        (Flambda.free_variables ~ignore_uses_as_callee:() decl.body))
+    decls.funs;
+  let arguments =
+    Variable.Map.fold
+      (fun _ decl acc ->
+         List.fold_left
+           (fun acc param ->
+              if Variable.Tbl.mem used_variables param then acc
+              else Variable.Set.add param acc)
+           acc decl.Flambda.params)
+      decls.funs Variable.Set.empty
+  in
+  arguments

middle_end/invariant_params.mli

@@ -0,0 +1,49 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* [invariant_params_in_recursion] calculates the set of parameters whose
+   values are known not to change during the execution of a recursive
+   function.  As such, occurrences of the parameters may always be replaced
+   by the corresponding values.
+
+   For example, [x] would be in [invariant_params] for both of the following
+   functions:
+
+     let rec f x y = (f x y) + (f x (y+1))
+
+     let rec f x l = List.iter (f x) l
+
+   For invariant parameters it also computes the set of parameters of functions
+   in the set of closures that are always aliased to it. For example in the set
+   of closures:
+
+     let rec f x y = (f x y) + (f x (y+1)) + g x
+     and g z = z + 1
+
+   The map of aliases is
+
+     x -> { x; z }
+*)
+val invariant_params_in_recursion
+   : Flambda.function_declarations
+  -> backend:(module Backend_intf.S)
+  -> Variable.Set.t Variable.Map.t
+
+(* CR-soon mshinwell: think about whether this function should
+   be in this file.  Should it be called "unused_parameters"? *)
+val unused_arguments
+   : Flambda.function_declarations
+  -> Variable.Set.t

middle_end/lift_code.ml

@@ -0,0 +1,163 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+module A = Simple_value_approx
+module C = Inlining_cost
+
+type lifter = Flambda.program -> Flambda.program
+
+let rebuild_let
+    (defs : (Variable.t * Flambda.named Flambda.With_free_variables.t) 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)
+    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 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
+
+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
+  | _ ->
+    acc, expr
+
+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 body = lift_lets_expr (W.contents body) ~toplevel in
+    rebuild_let (List.rev rev_defs) body
+  | e ->
+    Flambda_iterators.map_subexpressions
+      (lift_lets_expr ~toplevel)
+      (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 =
+  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
+
+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)
+  | Set_of_closures set when not toplevel ->
+    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
+
+module Sort_lets = Sort_connected_components.Make(Variable)
+
+let rebuild_let_rec (defs:(Variable.t * Flambda.named) list) body =
+  let map = Variable.Map.of_list defs in
+  let graph =
+    Variable.Map.map
+      (fun named ->
+         Variable.Set.filter (fun v -> Variable.Map.mem v map)
+           (Flambda.free_variables_named named))
+      map
+  in
+  let components =
+    Sort_lets.connected_components_sorted_from_roots_to_leaf graph
+  in
+  Array.fold_left (fun body (component:Sort_lets.component) ->
+      match component with
+      | No_loop v ->
+          let def = Variable.Map.find v map in
+          Flambda.create_let v def body
+      | Has_loop l ->
+          Flambda.Let_rec
+            (List.map (fun v -> v, Variable.Map.find v map) l,
+             body))
+    body components
+
+let lift_let_rec program =
+  Flambda_iterators.map_exprs_at_toplevel_of_program program
+    ~f:(Flambda_iterators.map_expr
+          (fun expr -> match expr with
+             | Let_rec (defs, body) ->
+                 rebuild_let_rec defs body
+             | expr -> expr))
+
+let lift_lets program =
+  let program = lift_let_rec program in
+  Flambda_iterators.map_exprs_at_toplevel_of_program program
+    ~f:(lift_lets_expr ~toplevel:false)
+
+let lifting_helper exprs ~evaluation_order ~create_body ~name =
+  let vars, lets =
+    (* [vars] corresponds elementwise to [exprs]; the order is unchanged. *)
+    List.fold_right (fun (flam : Flambda.t) (vars, lets) ->
+        match flam with
+        | Var v ->
+          (* Note that [v] is (statically) always an immutable variable. *)
+          v::vars, lets
+        | expr ->
+          let v =
+            Variable.create name ~current_compilation_unit:
+                (Compilation_unit.get_current_exn ())
+          in
+          v::vars, (v, expr)::lets)
+      exprs ([], [])
+  in
+  let lets =
+    match evaluation_order with
+    | `Right_to_left -> lets
+    | `Left_to_right -> List.rev lets
+  in
+  List.fold_left (fun body (v, expr) ->
+      Flambda.create_let v (Expr expr) body)
+    (create_body vars) lets

middle_end/lift_code.mli

@@ -0,0 +1,41 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type lifter = Flambda.program -> Flambda.program
+
+(** Lift [let] bindings to attempt to increase the length of scopes, as an
+    aid to further optimizations.  For example:
+      let c = let b = <expr> in b, b in fst c
+    would be transformed to:
+      let b = <expr> in let c = b, b in fst c
+    which is then clearly just:
+      <expr>
+*)
+val lift_lets : lifter
+
+val lift_lets_expr : Flambda.t -> toplevel:bool -> Flambda.t
+
+(* CR-someday mshinwell: Rename to [bind]?  Also see Flambda_utils.bind. *)
+(* [create_body] always receives the variables corresponding to [evaluate]
+   in the same order.  However [evaluation_order] specifies in which order
+   the (possibly complex) expressions bound to those variables are
+   evaluated. *)
+val lifting_helper
+   : Flambda.t list
+  -> evaluation_order:[ `Left_to_right | `Right_to_left ]
+  -> create_body:(Variable.t list -> Flambda.t)
+  -> name:string
+  -> Flambda.t

middle_end/lift_constants.ml

@@ -0,0 +1,959 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+let rec tail_variable : Flambda.t -> Variable.t option = function
+  | Var v -> Some v
+  | Let_rec (_, e)
+  | Let_mutable (_, _, e)
+  | Let { body = e; _ } -> tail_variable e
+  | _ -> None
+
+let closure_symbol ~(backend:(module Backend_intf.S)) closure_id =
+  let module Backend = (val backend) in
+  Backend.closure_symbol closure_id
+
+let make_variable_symbol prefix var =
+  Symbol.create (Compilation_unit.get_current_exn ())
+    (Linkage_name.create
+       (prefix ^ Variable.unique_name (Variable.rename var)))
+
+(** Traverse the given expression assigning symbols to [let]- and [let rec]-
+    bound constant variables.  At the same time collect the definitions of
+    such variables. *)
+let assign_symbols_and_collect_constant_definitions
+    ~(backend : (module Backend_intf.S))
+    ~(program : Flambda.program)
+    ~(inconstants : Inconstant_idents.result) =
+  let var_to_symbol_tbl = Variable.Tbl.create 42 in
+  let var_to_definition_tbl = Variable.Tbl.create 42 in
+  let module AA = Alias_analysis in
+  let assign_symbol var (named : Flambda.named) =
+    if not (Inconstant_idents.variable var inconstants) then begin
+      let assign_symbol () =
+        let symbol = make_variable_symbol "" var in
+        Variable.Tbl.add var_to_symbol_tbl var symbol
+      in
+      let assign_existing_symbol = Variable.Tbl.add var_to_symbol_tbl var in
+      let record_definition = Variable.Tbl.add var_to_definition_tbl var in
+      match named with
+      | Symbol symbol ->
+        assign_existing_symbol symbol;
+        record_definition (AA.Symbol symbol)
+      | Const const -> record_definition (AA.Const const)
+      | Allocated_const const ->
+        assign_symbol ();
+        record_definition (AA.Allocated_const (Normal const))
+      | Read_mutable _ -> () (* CR mshinwell: should be assert false? *)
+      | Prim (Pmakeblock (tag, _), fields, _) ->
+        assign_symbol ();
+        record_definition (AA.Block (Tag.create_exn tag, fields))
+      | Read_symbol_field (symbol, field) ->
+        record_definition (AA.Symbol_field (symbol, field))
+      | Set_of_closures (
+          { function_decls = { funs; set_of_closures_id; _ };
+            _ } as set) ->
+        assert (not (Inconstant_idents.closure set_of_closures_id
+                       inconstants));
+        assign_symbol ();
+        record_definition (AA.Set_of_closures set);
+        Variable.Map.iter (fun fun_var _ ->
+            let closure_id = Closure_id.wrap fun_var in
+            let closure_symbol = closure_symbol ~backend closure_id in
+            Variable.Tbl.add var_to_symbol_tbl fun_var closure_symbol;
+            let project_closure =
+              Alias_analysis.Project_closure
+                { set_of_closures = var; closure_id }
+            in
+            Variable.Tbl.add var_to_definition_tbl fun_var
+              project_closure)
+          funs
+      | Move_within_set_of_closures ({ closure = _; start_from = _; move_to; } as move) ->
+        assign_existing_symbol (closure_symbol ~backend  move_to);
+        record_definition (AA.Move_within_set_of_closures move)
+      | Project_closure ({ closure_id } as project_closure) ->
+        assign_existing_symbol (closure_symbol ~backend  closure_id);
+        record_definition (AA.Project_closure project_closure)
+      | Prim (Pfield index, [block], _) ->
+        record_definition (AA.Field (block, index))
+      | Prim (Pfield _, _, _) ->
+        Misc.fatal_errorf "[Pfield] with the wrong number of arguments"
+          Flambda.print_named named
+      | Prim (Pmakearray (Pfloatarray as kind, mutability), args, _) ->
+        assign_symbol ();
+        record_definition (AA.Allocated_const (Array (kind, mutability, args)))
+      | Prim (Pduparray (kind, mutability), [arg], _) ->
+        assign_symbol ();
+        record_definition (AA.Allocated_const (
+          Duplicate_array (kind, mutability, arg)))
+      | Prim _ ->
+        Misc.fatal_errorf "Primitive not expected to be constant: @.%a@."
+          Flambda.print_named named
+      | Project_var project_var ->
+        record_definition (AA.Project_var project_var)
+      | Expr e -> begin
+          match tail_variable e with
+          (* CR mshinwell for pchambart: What should happen here?
+             Move [tail_variable] to [Flambda_utils] once decided *)
+          | None -> () (* Fail ? *)
+          | Some v -> record_definition (AA.Variable v)
+        end
+    end
+  in
+  let assign_symbol_program expr =
+    Flambda_iterators.iter_all_immutable_let_and_let_rec_bindings expr
+      ~f:assign_symbol
+  in
+  Flambda_iterators.iter_exprs_at_toplevel_of_program
+    ~f:assign_symbol_program
+    program;
+  let let_symbol_to_definition_tbl = Symbol.Tbl.create 42 in
+  let initialize_symbol_to_definition_tbl = Symbol.Tbl.create 42 in
+  let rec collect_let_and_initialize_symbols (program : Flambda.program_body) =
+    match program with
+    | Let_symbol (symbol, decl, program) ->
+      Symbol.Tbl.add let_symbol_to_definition_tbl symbol decl;
+      collect_let_and_initialize_symbols program
+    | Let_rec_symbol (decls, program) ->
+      List.iter (fun (symbol, decl) ->
+          Symbol.Tbl.add let_symbol_to_definition_tbl symbol decl)
+        decls;
+      collect_let_and_initialize_symbols program
+    | Effect (_, program) -> collect_let_and_initialize_symbols program
+    | Initialize_symbol (symbol,_tag,fields,program) ->
+      collect_let_and_initialize_symbols program;
+      let fields = List.map tail_variable fields in
+      Symbol.Tbl.add initialize_symbol_to_definition_tbl symbol fields
+    | End _ -> ()
+  in
+  collect_let_and_initialize_symbols program.program_body;
+  let record_set_of_closure_equalities (set_of_closures:Flambda.set_of_closures) =
+    Variable.Map.iter (fun arg var ->
+        if not (Inconstant_idents.variable arg inconstants) then
+          Variable.Tbl.add var_to_definition_tbl arg (AA.Variable var))
+      set_of_closures.free_vars;
+    Variable.Map.iter (fun arg var ->
+        if not (Inconstant_idents.variable arg inconstants) then
+          Variable.Tbl.add var_to_definition_tbl arg (AA.Variable var))
+      set_of_closures.specialised_args
+  in
+  Flambda_iterators.iter_on_set_of_closures_of_program program
+    ~f:(fun ~constant set_of_closures ->
+      record_set_of_closure_equalities set_of_closures;
+      if constant then begin
+        Variable.Map.iter (fun fun_var _ ->
+            let closure_id = Closure_id.wrap fun_var in
+            let closure_symbol = closure_symbol ~backend closure_id in
+            Variable.Tbl.add var_to_definition_tbl fun_var
+              (AA.Symbol closure_symbol);
+            Variable.Tbl.add var_to_symbol_tbl fun_var closure_symbol)
+          set_of_closures.Flambda.function_decls.funs
+      end);
+  var_to_symbol_tbl, var_to_definition_tbl,
+    let_symbol_to_definition_tbl, initialize_symbol_to_definition_tbl
+
+let variable_field_definition
+    (var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
+    (var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
+    (var:Variable.t) : Flambda.constant_defining_value_block_field =
+  try
+    Symbol (Variable.Tbl.find var_to_symbol_tbl var)
+  with Not_found ->
+    match Variable.Tbl.find var_to_definition_tbl var with
+    | Const c -> Const c
+    | const_defining_value ->
+      Misc.fatal_errorf "Unexpected pattern for a constant: %a: %a"
+        Variable.print var
+        Alias_analysis.print_constant_defining_value const_defining_value
+    | exception Not_found ->
+      Misc.fatal_errorf "No associated symbol for the constant %a"
+        Variable.print var
+
+let resolve_variable
+    (aliases:Alias_analysis.allocation_point Variable.Map.t)
+    (var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
+    (var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
+    (var:Variable.t) : Flambda.constant_defining_value_block_field =
+  match Variable.Map.find var aliases with
+  | exception Not_found ->
+    variable_field_definition var_to_symbol_tbl var_to_definition_tbl var
+  | Symbol s -> Symbol s
+  | Variable aliased_variable ->
+    variable_field_definition var_to_symbol_tbl var_to_definition_tbl aliased_variable
+
+let translate_set_of_closures
+    (inconstants:Inconstant_idents.result)
+    (aliases:Alias_analysis.allocation_point Variable.Map.t)
+    (var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
+    (var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
+    (set_of_closures:Flambda.set_of_closures) =
+  let f var (named:Flambda.named) : Flambda.named =
+    if Inconstant_idents.variable var inconstants then
+      named
+    else
+      let resolved =
+        resolve_variable
+          aliases
+          var_to_symbol_tbl
+          var_to_definition_tbl
+          var
+      in
+      match resolved with
+      | Symbol s -> Symbol s
+      | Const c -> Const c
+  in
+  Flambda_iterators.map_function_bodies set_of_closures
+    ~f:(Flambda_iterators.map_all_immutable_let_and_let_rec_bindings ~f)
+
+let translate_constant_set_of_closures
+    (inconstants:Inconstant_idents.result)
+    (aliases:Alias_analysis.allocation_point Variable.Map.t)
+    (var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
+    (var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
+    (constant_defining_values:Flambda.constant_defining_value Symbol.Map.t) =
+  Symbol.Map.map (fun (const:Flambda.constant_defining_value) ->
+      match const with
+      | Flambda.Allocated_const _
+      | Flambda.Block _
+      | Flambda.Project_closure _ ->
+        const
+      | Flambda.Set_of_closures set_of_closures ->
+        let set_of_closures =
+          translate_set_of_closures
+            (inconstants:Inconstant_idents.result)
+            (aliases:Alias_analysis.allocation_point Variable.Map.t)
+            (var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
+            (var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
+            (set_of_closures:Flambda.set_of_closures)
+        in
+        Flambda.Set_of_closures set_of_closures)
+    constant_defining_values
+
+let find_original_set_of_closure
+    (aliases:Alias_analysis.allocation_point Variable.Map.t)
+    (var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
+    (var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
+    project_closure_map
+    var =
+  let rec loop var =
+    match Variable.Map.find var aliases with
+    | Variable var -> begin
+        match Variable.Tbl.find var_to_definition_tbl var with
+        | Project_closure { set_of_closures = var }
+        | Move_within_set_of_closures { closure = var } ->
+          loop var
+        | Set_of_closures _ -> begin
+            match Variable.Tbl.find var_to_symbol_tbl var with
+            | s ->
+              s
+            | exception Not_found ->
+              Format.eprintf "var: %a@." Variable.print var;
+              assert false
+          end
+        | _ -> assert false
+      end
+    | Symbol s ->
+      match Symbol.Map.find s project_closure_map with
+      | exception Not_found ->
+        assert false
+      | s -> s
+  in
+  loop var
+
+let rec translate_definition_and_resolve_alias
+    inconstants
+    (aliases:Alias_analysis.allocation_point Variable.Map.t)
+    (var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
+    (var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
+    (symbol_definition_map : Flambda.constant_defining_value Symbol.Map.t)
+    (project_closure_map:Symbol.t Symbol.Map.t)
+    (definition:Alias_analysis.constant_defining_value)
+    ~(backend:(module Backend_intf.S))
+  : Flambda.constant_defining_value option =
+  match definition with
+  | Block (tag, fields) ->
+    Some (Flambda.Block (tag, List.map (resolve_variable aliases var_to_symbol_tbl var_to_definition_tbl) fields))
+  | Allocated_const (Normal const) -> Some (Flambda.Allocated_const const)
+  | Allocated_const (Duplicate_array (Pfloatarray, mutability, var)) ->
+    (* CR-someday mshinwell: This next section could do with cleanup.
+       What happens is:
+        - Duplicate contains a variable, which is resolved to
+        a float array thing full of variables;
+        - We send that value back through this function again so the
+        individual members of that array are resolved from variables to
+        floats.
+        - Then we can build the Flambda.name term containing the
+        Allocated_const (full of floats).
+       We should maybe factor out the code from the Allocated_const (Array (...))
+       case below so this function doesn't have to be recursive. *)
+    let (constant_defining_value : Alias_analysis.constant_defining_value) =
+      match Variable.Map.find var aliases with
+      | exception Not_found ->
+        Variable.Tbl.find var_to_definition_tbl var
+      | Variable var ->
+        Variable.Tbl.find var_to_definition_tbl var
+      | Symbol sym ->
+        match Symbol.Map.find sym symbol_definition_map with
+        | Allocated_const ((Immutable_float_array _) as const) ->
+          Alias_analysis.Allocated_const (Normal const)
+        | (Allocated_const _ | Block _ | Set_of_closures _
+            | Project_closure _) as wrong ->
+          Misc.fatal_errorf
+            "Lift_constants.translate_definition_and_resolve_alias: \
+              Duplicate Pfloatarray %a with symbol %a mapping to \
+              wrong constant defining value %a"
+            Variable.print var
+            Alias_analysis.print_constant_defining_value definition
+            Flambda.print_constant_defining_value wrong
+        | exception Not_found ->
+          let module Backend = (val backend) in
+          match (Backend.import_symbol sym).descr with
+          | Value_unresolved _ ->
+            Misc.fatal_errorf
+              "Lift_constants.translate_definition_and_resolve_alias: \
+               Duplicate Pfloatarray %a with unknown symbol: %a"
+              Variable.print var
+              Alias_analysis.print_constant_defining_value definition
+          | Value_float_array { contents = Contents float_array } ->
+            let contents =
+              Array.fold_right (fun elt acc ->
+                  match acc, elt with
+                  | None, _ | _, None -> None
+                  | Some acc, Some f ->
+                    Some (f :: acc))
+                float_array (Some [])
+            in
+            begin match contents with
+            | None ->
+              Misc.fatal_errorf
+                "Lift_constants.translate_definition_and_resolve_alias: \
+                 Duplicate Pfloatarray %a with not completely known float \
+                 array from symbol: %a"
+                Variable.print var
+                Alias_analysis.print_constant_defining_value definition
+            | Some l ->
+              Alias_analysis.Allocated_const (Normal (Immutable_float_array l))
+            end
+          | wrong ->
+            Misc.fatal_errorf
+              "Lift_constants.translate_definition_and_resolve_alias: \
+               Duplicate Pfloatarray %a with symbol %a mapping to \
+               wrong value %a"
+              Variable.print var
+              Alias_analysis.print_constant_defining_value definition
+              Simple_value_approx.print_descr wrong
+    in
+    begin match constant_defining_value with
+    | Allocated_const (Normal (Float_array _)) ->
+      (* This example from pchambart illustrates why we do not allow
+         the duplication of mutable arrays:
+
+         {|
+         let_symbol a = Allocated_const (Immutable_float_array [|0.|])
+         initialize_symbol b = Duparray(Mutable, a)
+         effect b.(0) <- 1.
+         initialize_symbol c = Duparray(Mutable, b)
+         |}
+
+         This will be converted to:
+         {|
+         let_symbol a = Allocated_const (Immutable_float_array [|0.|])
+         let_symbol b = Allocated_const (Float_array [|0.|])
+         effect b.(0) <- 1.
+         let_symbol c = Allocated_const (Float_array [|0.|])
+         |}
+
+         We can't encounter that currently, but it's scary.
+      *)
+      Misc.fatal_error "Pduparray is not allowed on mutable arrays"
+    | Allocated_const (Normal (Immutable_float_array floats)) ->
+      let const : Allocated_const.t =
+        match mutability with
+        | Immutable -> Immutable_float_array floats
+        | Mutable -> Float_array floats
+      in
+      Some (Flambda.Allocated_const const)
+    | (Allocated_const (Array (Pfloatarray, _, _))) as definition ->
+      translate_definition_and_resolve_alias inconstants aliases
+        var_to_symbol_tbl var_to_definition_tbl symbol_definition_map
+        project_closure_map definition
+        ~backend
+    | const ->
+      Misc.fatal_errorf
+        "Lift_constants.translate_definition_and_resolve_alias: \
+          Duplicate Pfloatarray %a with wrong argument: %a"
+        Variable.print var
+        Alias_analysis.print_constant_defining_value const
+    end
+  | Allocated_const (Duplicate_array (_, _, _)) ->
+    Misc.fatal_errorf "Lift_constants.translate_definition_and_resolve_alias: \
+        Duplicate_array with non-Pfloatarray kind: %a"
+      Alias_analysis.print_constant_defining_value definition
+  | Allocated_const (Array (Pfloatarray, mutability, vars)) ->
+    let floats =
+      List.map (fun var ->
+          let var =
+            match Variable.Map.find var aliases with
+            | exception Not_found -> var
+            | Symbol _ ->
+              Misc.fatal_errorf
+                "Lift_constants.translate_definition_and_resolve_alias: \
+                  Array Pfloatarray %a with Symbol argument: %a"
+                Variable.print var
+                Alias_analysis.print_constant_defining_value definition
+            | Variable var -> var
+          in
+          match Variable.Tbl.find var_to_definition_tbl var with
+          | Allocated_const (Normal (Float f)) -> f
+          | const_defining_value ->
+            Misc.fatal_errorf "Bad definition for float array member %a: %a"
+              Variable.print var
+              Alias_analysis.print_constant_defining_value
+                const_defining_value)
+        vars
+    in
+    let const : Allocated_const.t =
+      match mutability with
+      | Immutable -> Immutable_float_array floats
+      | Mutable -> Float_array floats
+    in
+    Some (Flambda.Allocated_const const)
+  | Allocated_const (Array (_, _, _)) ->
+    Misc.fatal_errorf "Lift_constants.translate_definition_and_resolve_alias: \
+        Array with non-Pfloatarray kind: %a"
+      Alias_analysis.print_constant_defining_value definition
+  | Project_closure { set_of_closures; closure_id } ->
+    begin match Variable.Map.find set_of_closures aliases with
+    | Symbol s ->
+      Some (Flambda.Project_closure (s, closure_id))
+    (* If a closure projection is a constant, the set of closures must
+       be assigned to a symbol. *)
+    | exception Not_found ->
+      assert false
+    | Variable v ->
+      match Variable.Tbl.find var_to_symbol_tbl v with
+      | s ->
+        Some (Flambda.Project_closure (s, closure_id))
+      | exception Not_found ->
+        Format.eprintf "var: %a@." Variable.print v;
+        assert false
+    end
+  | Move_within_set_of_closures { closure; move_to } ->
+    let set_of_closure_symbol =
+      find_original_set_of_closure
+        aliases
+        var_to_symbol_tbl
+        var_to_definition_tbl
+        project_closure_map
+        closure
+    in
+    Some (Flambda.Project_closure (set_of_closure_symbol, move_to))
+  | Set_of_closures set_of_closures ->
+    let set_of_closures =
+      translate_set_of_closures
+        inconstants
+        aliases
+        var_to_symbol_tbl
+        var_to_definition_tbl
+        set_of_closures
+    in
+    Some (Flambda.Set_of_closures set_of_closures)
+
+  | Project_var _ -> None
+  | Field (_,_) | Symbol_field _ -> None
+  | Const _ -> None
+  | Symbol _ -> None
+  | Variable _ -> None
+
+let translate_definitions_and_resolve_alias
+    inconstants
+    (aliases:Alias_analysis.allocation_point Variable.Map.t)
+    (var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
+    (var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
+    symbol_definition_map
+    project_closure_map
+    ~backend =
+  Variable.Tbl.fold (fun var def map ->
+      match translate_definition_and_resolve_alias inconstants aliases ~backend
+              var_to_symbol_tbl var_to_definition_tbl symbol_definition_map
+              project_closure_map def with
+      | None -> map
+      | Some def ->
+        let symbol = Variable.Tbl.find var_to_symbol_tbl var in
+        Symbol.Map.add symbol def map)
+    var_to_definition_tbl Symbol.Map.empty
+
+(* Resorting of graph including Initialize_symbol *)
+let constant_dependencies ~backend:_ (const:Flambda.constant_defining_value) =
+  match const with
+  | Allocated_const _ -> Symbol.Set.empty
+  | Block (_, fields) ->
+    let symbol_fields = Misc.filter_map
+        (function
+          | (Symbol s:Flambda.constant_defining_value_block_field) -> Some s
+          | Flambda.Const _ -> None)
+        fields
+    in
+    Symbol.Set.of_list symbol_fields
+  | Set_of_closures set_of_closures ->
+    Flambda.free_symbols_named (Set_of_closures set_of_closures)
+  | Project_closure (s, _) ->
+    Symbol.Set.singleton s
+
+let program_graph
+    ~backend
+    imported_symbols symbol_to_constant
+    (initialize_symbol_tbl : (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t)
+    (effect_tbl : (Flambda.t * Symbol.t option) Symbol.Tbl.t) =
+  let expression_symbol_dependencies expr = Flambda.free_symbols expr in
+  let graph_with_only_constant_parts =
+    Symbol.Map.map (fun const ->
+        Symbol.Set.diff (constant_dependencies ~backend const) imported_symbols)
+      symbol_to_constant
+  in
+  let graph_with_initialisation =
+    Symbol.Tbl.fold (fun sym (_tag, fields, previous) ->
+        let order_dep =
+          match previous with
+          | None -> Symbol.Set.empty
+          | Some previous -> Symbol.Set.singleton previous
+        in
+        let deps = List.fold_left (fun set field ->
+            Symbol.Set.union (expression_symbol_dependencies field) set)
+            order_dep fields
+        in
+        let deps = Symbol.Set.diff deps imported_symbols in
+        Symbol.Map.add sym deps)
+      initialize_symbol_tbl graph_with_only_constant_parts
+  in
+  let graph =
+    Symbol.Tbl.fold (fun sym (expr, previous) ->
+        let order_dep =
+          match previous with
+          | None -> Symbol.Set.empty
+          | Some previous -> Symbol.Set.singleton previous
+        in
+        let deps = Symbol.Set.union (expression_symbol_dependencies expr) order_dep in
+        let deps = Symbol.Set.diff deps imported_symbols in
+        Symbol.Map.add sym deps
+      )
+      effect_tbl graph_with_initialisation
+  in
+  let module Symbol_SCC = Sort_connected_components.Make (Symbol) in
+  let components =
+    Symbol_SCC.connected_components_sorted_from_roots_to_leaf
+      graph
+  in
+  components
+
+(* rebuilding the program *)
+let add_definition_of_symbol constant_definitions
+    (initialize_symbol_tbl : (Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t)
+    (effect_tbl:(Flambda.t * Symbol.t option) Symbol.Tbl.t)
+    (program : Flambda.program_body) component : Flambda.program_body =
+  let symbol_declaration sym =
+    (* A symbol declared through an Initialize_symbol construct
+       cannot be recursive, this is not allowed in the construction.
+       This also couldn't have been introduced by this pass, so we can
+       safely assert that this is not possible here *)
+    assert(not (Symbol.Tbl.mem initialize_symbol_tbl sym));
+    (sym, Symbol.Map.find sym constant_definitions)
+  in
+  let module Symbol_SCC = Sort_connected_components.Make (Symbol) in
+  match component with
+  | Symbol_SCC.Has_loop l ->
+    let l = List.map symbol_declaration l in
+    Let_rec_symbol (l, program)
+  | Symbol_SCC.No_loop sym ->
+    match Symbol.Tbl.find initialize_symbol_tbl sym with
+    | (tag, fields, _previous) ->
+      Initialize_symbol (sym, tag, fields, program)
+    | exception Not_found ->
+      match Symbol.Tbl.find effect_tbl sym with
+      | (expr, _previous) ->
+        Effect (expr, program)
+      | exception Not_found ->
+        let decl = Symbol.Map.find sym constant_definitions in
+        Let_symbol (sym, decl, program)
+
+let add_definitions_of_symbols constant_definitions initialize_symbol_tbl
+    effect_tbl program components =
+  Array.fold_left
+    (add_definition_of_symbol constant_definitions initialize_symbol_tbl
+      effect_tbl)
+    program components
+
+let introduce_free_variables_in_set_of_closures
+    (var_to_block_field_tbl:Flambda.constant_defining_value_block_field Variable.Tbl.t)
+    ({ Flambda.function_decls; free_vars; specialised_args }
+      as set_of_closures) =
+  let add_definition_and_make_substitution var (expr, subst) =
+    let searched_var =
+      match Variable.Map.find var specialised_args with
+      | exception Not_found -> var
+      | external_var ->
+        (* specialised arguments bound to constant can be rewritten *)
+        external_var
+    in
+    match Variable.Tbl.find var_to_block_field_tbl searched_var with
+    | def ->
+      let fresh = Variable.rename var in
+      let named : Flambda.named = match def with
+        | Symbol sym -> Symbol sym
+        | Const c -> Const c
+      in
+      (Flambda.create_let fresh named expr), Variable.Map.add var fresh subst
+    | exception Not_found ->
+      (* The variable is bound by the closure or the arguments or not
+         constant. In either case it does not need to be bound *)
+      expr, subst
+  in
+  let done_something = ref false in
+  let function_decls : Flambda.function_declarations =
+    Flambda.update_function_declarations function_decls
+      ~funs:(Variable.Map.mapi
+          (fun _fun_var (func_decl : Flambda.function_declaration) ->
+             let variables_to_bind =
+               (* Closures from the same set must not be bound. *)
+               Variable.Set.diff func_decl.free_variables
+                 (Variable.Map.keys function_decls.funs)
+             in
+             let body, subst =
+               Variable.Set.fold add_definition_and_make_substitution
+                 variables_to_bind
+                 (func_decl.body, Variable.Map.empty)
+             in
+             if Variable.Map.is_empty subst then
+               func_decl
+             else begin
+               done_something := true;
+               let body = Flambda_utils.toplevel_substitution subst body in
+               Flambda.create_function_declaration
+                 ~params:func_decl.params
+                 ~body
+                 ~stub:func_decl.stub
+                 ~dbg:func_decl.dbg
+                 ~inline:func_decl.inline
+                 ~is_a_functor:func_decl.is_a_functor
+             end)
+          function_decls.funs)
+  in
+  let free_vars =
+    (* Keep only those that are not rewritten to constants. *)
+    Variable.Map.filter (fun v _ ->
+        let keep = not (Variable.Tbl.mem var_to_block_field_tbl v) in
+        if not keep then done_something := true;
+        keep)
+      free_vars
+  in
+  let specialised_args =
+    (* Keep only those that are not rewritten to constants. *)
+    Variable.Map.filter (fun _ v ->
+        let keep = not (Variable.Tbl.mem var_to_block_field_tbl v) in
+        if not keep then done_something := true;
+        keep)
+      specialised_args
+  in
+  if not !done_something then
+    set_of_closures
+  else
+    Flambda.create_set_of_closures ~function_decls ~free_vars ~specialised_args
+
+let rewrite_project_var
+      (var_to_block_field_tbl
+        : Flambda.constant_defining_value_block_field Variable.Tbl.t)
+      (project_var : Flambda.project_var) ~original : Flambda.named =
+  let var = Var_within_closure.unwrap project_var.var in
+  match Variable.Tbl.find var_to_block_field_tbl var with
+  | exception Not_found -> original
+  | Symbol sym -> Symbol sym
+  | Const const -> Const const
+
+let introduce_free_variables_in_sets_of_closures
+    (var_to_block_field_tbl:Flambda.constant_defining_value_block_field Variable.Tbl.t)
+    (translate_definition:Flambda.constant_defining_value Symbol.Map.t) =
+  Symbol.Map.map (fun (def:Flambda.constant_defining_value) ->
+      match def with
+      | Allocated_const _
+      | Block _
+      | Project_closure _ -> def
+      | Set_of_closures set_of_closures ->
+        Flambda.Set_of_closures
+          (introduce_free_variables_in_set_of_closures
+             var_to_block_field_tbl
+             set_of_closures))
+    translate_definition
+
+let var_to_block_field
+    (aliases:Alias_analysis.allocation_point Variable.Map.t)
+    (var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
+    (var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
+  =
+  let var_to_block_field_tbl = Variable.Tbl.create 42 in
+  Variable.Tbl.iter (fun var _ ->
+      let def =
+        resolve_variable aliases var_to_symbol_tbl var_to_definition_tbl var
+      in
+      Variable.Tbl.add var_to_block_field_tbl var def
+    )
+    var_to_definition_tbl;
+  var_to_block_field_tbl
+
+let program_symbols ~backend (program : Flambda.program) =
+  let new_fake_symbol =
+    let r = ref 0 in
+    fun () ->
+      incr r;
+      Symbol.create (Compilation_unit.get_current_exn ())
+        (Linkage_name.create ("fake_effect_symbol_" ^ string_of_int !r))
+  in
+  let initialize_symbol_tbl = Symbol.Tbl.create 42 in
+  let effect_tbl = Symbol.Tbl.create 42 in
+  let symbol_definition_tbl = Symbol.Tbl.create 42 in
+  let add_project_closure_definitions def_symbol (const:Flambda.constant_defining_value) =
+    match const with
+    | Set_of_closures { function_decls = { funs } } ->
+        Variable.Map.iter (fun fun_var _ ->
+            let closure_id = Closure_id.wrap fun_var in
+            let closure_symbol = closure_symbol ~backend closure_id in
+            let project_closure =
+              Flambda.Project_closure (def_symbol, closure_id)
+            in
+            Symbol.Tbl.add symbol_definition_tbl closure_symbol
+              project_closure)
+          funs
+    | Project_closure _
+    | Allocated_const _
+    | Block _ -> ()
+  in
+  let rec loop (program : Flambda.program_body) previous_effect =
+    match program with
+    | Flambda.Let_symbol (symbol, def, program) ->
+      add_project_closure_definitions symbol def;
+      Symbol.Tbl.add symbol_definition_tbl symbol def;
+      loop program previous_effect
+    | Flambda.Let_rec_symbol (defs, program) ->
+      List.iter (fun (symbol, def) ->
+          add_project_closure_definitions symbol def;
+          Symbol.Tbl.add symbol_definition_tbl symbol def)
+        defs;
+      loop program previous_effect
+    | Flambda.Initialize_symbol (symbol, tag, fields, program) ->
+      (* previous_effect is used to keep the order of initialize and effect
+         values. Their effects order must be kept ordered.
+         it is used as an extra dependency when sorting the symbols. *)
+      (* CR-someday pchambart: if the fields expressions are pure, we could
+         drop this dependency
+         mshinwell: deferred CR *)
+      Symbol.Tbl.add initialize_symbol_tbl symbol
+        (tag, fields, previous_effect);
+      loop program (Some symbol)
+    | Flambda.Effect (expr, program) ->
+      (* Used to ensure that effects are correctly ordered *)
+      let fake_effect_symbol = new_fake_symbol () in
+      Symbol.Tbl.add effect_tbl fake_effect_symbol (expr, previous_effect);
+      loop program (Some fake_effect_symbol)
+    | Flambda.End _ -> ()
+  in
+  loop program.program_body None;
+  initialize_symbol_tbl, symbol_definition_tbl, effect_tbl
+
+let replace_definitions_in_initialize_symbol_and_effects
+    (inconstants:Inconstant_idents.result)
+    (aliases:Alias_analysis.allocation_point Variable.Map.t)
+    (var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
+    (var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
+    (initialize_symbol_tbl:(Tag.t * Flambda.t list * Symbol.t option) Symbol.Tbl.t)
+    (effect_tbl:(Flambda.t * Symbol.t option) Symbol.Tbl.t) =
+  let rewrite_expr expr =
+    Flambda_iterators.map_all_immutable_let_and_let_rec_bindings expr
+      ~f:(fun var (named : Flambda.named) : Flambda.named ->
+        if Inconstant_idents.variable var inconstants then
+          named
+        else
+          let resolved =
+            resolve_variable
+              aliases
+              var_to_symbol_tbl
+              var_to_definition_tbl
+              var
+          in
+          match resolved with
+          | Symbol s -> Symbol s
+          | Const c -> Const c)
+  in
+  (* This is safe because we only [replace] the current key during
+     iteration (cf. https://github.com/ocaml/ocaml/pull/337) *)
+  Symbol.Tbl.iter
+    (fun symbol (tag, fields, previous) ->
+      let fields = List.map rewrite_expr fields in
+      Symbol.Tbl.replace initialize_symbol_tbl symbol (tag, fields, previous))
+    initialize_symbol_tbl;
+  Symbol.Tbl.iter
+    (fun symbol (expr, previous) ->
+      Symbol.Tbl.replace effect_tbl symbol (rewrite_expr expr, previous))
+    effect_tbl
+
+let project_closure_map symbol_definition_map =
+  Symbol.Map.fold (fun sym (const:Flambda.constant_defining_value) acc ->
+      match const with
+      | Project_closure (set_of_closures, _) ->
+        Symbol.Map.add sym set_of_closures acc
+      | Set_of_closures _
+      | Allocated_const _
+      | Block _ -> acc)
+    symbol_definition_map
+    Symbol.Map.empty
+
+let lift_constants (program : Flambda.program) ~backend =
+  (* Format.eprintf "lift_constants input:@ %a\n" Flambda.print_program program; *)
+  let inconstants =
+    Inconstant_idents.inconstants_on_program program
+      ~backend
+      ~compilation_unit:(Compilation_unit.get_current_exn ())
+  in
+  let initialize_symbol_tbl, symbol_definition_tbl, effect_tbl =
+    program_symbols ~backend program
+  in
+  let var_to_symbol_tbl, var_to_definition_tbl, let_symbol_to_definition_tbl,
+      initialize_symbol_to_definition_tbl =
+    assign_symbols_and_collect_constant_definitions ~backend ~program ~inconstants
+  in
+  let aliases =
+    Alias_analysis.run var_to_definition_tbl
+      initialize_symbol_to_definition_tbl
+      let_symbol_to_definition_tbl
+  in
+  replace_definitions_in_initialize_symbol_and_effects
+      (inconstants:Inconstant_idents.result)
+      (aliases:Alias_analysis.allocation_point Variable.Map.t)
+      (var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
+      (var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
+      initialize_symbol_tbl
+      effect_tbl;
+  let symbol_definition_map =
+    translate_constant_set_of_closures
+      (inconstants:Inconstant_idents.result)
+      (aliases:Alias_analysis.allocation_point Variable.Map.t)
+      (var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
+      (var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
+      (Symbol.Tbl.to_map symbol_definition_tbl)
+  in
+  let project_closure_map = project_closure_map symbol_definition_map in
+  let translated_definitions =
+    translate_definitions_and_resolve_alias
+      inconstants
+      (aliases:Alias_analysis.allocation_point Variable.Map.t)
+      (var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
+      (var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
+      symbol_definition_map
+      project_closure_map
+      ~backend
+  in
+  let var_to_block_field_tbl =
+    var_to_block_field
+      (aliases:Alias_analysis.allocation_point Variable.Map.t)
+      (var_to_symbol_tbl:Symbol.t Variable.Tbl.t)
+      (var_to_definition_tbl:Alias_analysis.constant_defining_value Variable.Tbl.t)
+  in
+  let translated_definitions =
+    introduce_free_variables_in_sets_of_closures var_to_block_field_tbl
+      translated_definitions
+  in
+  let constant_definitions =
+    (* Add previous Let_symbol to the newly discovered ones *)
+    Symbol.Map.union
+      (fun _sym
+        (c1:Flambda.constant_defining_value)
+        (c2:Flambda.constant_defining_value) ->
+        match c1, c2 with
+        | Project_closure (s1, closure_id1),
+          Project_closure (s2, closure_id2) when
+            Symbol.equal s1 s2 &&
+            Closure_id.equal closure_id1 closure_id2 ->
+          c1
+        | Project_closure (s1, closure_id1),
+          Project_closure (s2, closure_id2) ->
+          Format.eprintf "not equal project closure@. s %a %a@. cid %a %a@."
+            Symbol.print s1 Symbol.print s2
+            Closure_id.print closure_id1 Closure_id.print closure_id2;
+          assert false
+        | _ ->
+          assert false
+      )
+      symbol_definition_map
+      translated_definitions
+  in
+  (* Upon the [Initialize_symbol]s, the [Effect]s and the constant definitions,
+     do the following:
+     1. Introduce [Let]s to bind variables that are going to be replaced
+     by constants.
+     2. If a variable bound by a closure gets replaced by a symbol and
+     thus eliminated from the [free_vars] set of the closure, we need to
+     rewrite any subsequent [Project_var] expressions that project that
+     variable. *)
+  let rewrite_expr expr =
+    Flambda_iterators.map_named (function
+        | (Set_of_closures set_of_closures) as named ->
+          let new_set_of_closures =
+            introduce_free_variables_in_set_of_closures
+              var_to_block_field_tbl set_of_closures
+          in
+          if new_set_of_closures == set_of_closures then
+            named
+          else
+            Set_of_closures new_set_of_closures
+        | (Project_var project_var) as original ->
+          rewrite_project_var var_to_block_field_tbl project_var ~original
+        | (Symbol _ | Const _ | Allocated_const _ | Project_closure _
+        | Move_within_set_of_closures _ | Prim _ | Expr _
+        | Read_mutable _ | Read_symbol_field _) as named -> named)
+      expr
+  in
+  let constant_definitions =
+    Symbol.Map.map (fun (const : Flambda.constant_defining_value) ->
+        match const with
+        | Allocated_const _ | Block _ | Project_closure _ -> const
+        | Set_of_closures set_of_closures ->
+          let set_of_closures =
+            Flambda_iterators.map_function_bodies set_of_closures
+              ~f:rewrite_expr
+          in
+          Flambda.Set_of_closures
+            (introduce_free_variables_in_set_of_closures
+              var_to_block_field_tbl set_of_closures))
+    constant_definitions
+  in
+  let effect_tbl =
+    Symbol.Tbl.map effect_tbl (fun (effect, dep) -> rewrite_expr effect, dep)
+  in
+  let initialize_symbol_tbl =
+    Symbol.Tbl.map initialize_symbol_tbl (fun (tag, fields, dep) ->
+      let fields = List.map rewrite_expr fields in
+      tag, fields, dep)
+  in
+  let imported_symbols = Flambda_utils.imported_symbols program in
+  let components =
+    program_graph ~backend imported_symbols constant_definitions
+      initialize_symbol_tbl effect_tbl
+  in
+  let program_body =
+    add_definitions_of_symbols constant_definitions
+      initialize_symbol_tbl
+      effect_tbl
+      (End (Flambda_utils.root_symbol program))
+      components
+  in
+  Flambda_utils.introduce_needed_import_symbols { program with program_body; }

middle_end/lift_constants.mli

@@ -0,0 +1,64 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* CR mshinwell: check comment is up to date *)
+(** The aim of this pass is to assign symbols to values known to be
+    constant (in other words, whose values we know at compile time), with
+    appropriate sharing of constants, and replace the occurrences of the
+    constants with their corresponding symbols.
+
+    This pass uses the results of two other passes, [Inconstant_idents] and
+    [Alias_analysis].  The relationship between these two deserves some
+    attention.
+
+    [Inconstant_idents] is a "backwards" analysis that propagates implications
+    about inconstantness of variables and set of closures IDs.
+
+    [Alias_analysis] is a "forwards" analysis that is analagous to the
+    propagation of [Simple_value_approx.t] values during [Inline_and_simplify].
+    It gives us information about relationships between values but not actually
+    about their constantness.
+
+    Combining these two into a single pass has been attempted previously,
+    but was not thought to be successful; this experiment could be repeated in
+    the future.  (If "constant" is considered as "top" and "inconstant" is
+    considered as "bottom", then [Alias_analysis] corresponds to a least fixed
+    point and [Inconstant_idents] corresponds to a greatest fixed point.)
+
+    At a high level, this pass operates as follows.  Symbols are assigned to
+    variables known to be constant and their defining expressions examined.
+    Based on the results of [Alias_analysis], we simplify the destructive
+    elements within the defining expressions (specifically, projection of
+    fields from blocks), to eventually yield [Flambda.constant_defining_value]s
+    that are entirely constructive.  These will be bound to symbols in the
+    resulting program.
+
+    Another approach to this pass could be to only use the results of
+    [Inconstant_idents] and then repeatedly lift constants and run
+    [Inline_and_simplify] until a fixpoint.  It was thought more robust to
+    instead use [Alias_analysis], where the fixpointing involves a less
+    complicated function.
+
+    We still run [Inline_and_simplify] once after this pass since the lifting
+    of constants may enable more functions to become closed; the simplification
+    pass provides an easy way of cleaning up (e.g. making sure [free_vars]
+    maps in sets of closures are correct).
+*)
+
+val lift_constants
+   : Flambda.program
+  -> backend:(module Backend_intf.S)
+  -> Flambda.program

middle_end/lift_let_to_initialize_symbol.ml

@@ -0,0 +1,292 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+type ('a, 'b) kind =
+  | Initialisation of (Symbol.t * Tag.t * Flambda.t list)
+  | Effect of 'b
+
+let should_copy (named:Flambda.named) =
+  match named with
+  | Symbol _ | Read_symbol_field _ | Const _ -> true
+  | _ -> false
+
+type extracted =
+  | Expr of Variable.t * Flambda.t
+  | Exprs of Variable.t list * Flambda.t
+  | Block of Variable.t * Tag.t * Variable.t list
+
+type accumulated = {
+  copied_lets : (Variable.t * Flambda.named) list;
+  extracted_lets : extracted list;
+  terminator : Flambda.expr;
+}
+
+let rec accumulate ~substitution ~copied_lets ~extracted_lets
+      (expr : Flambda.t) =
+  match expr with
+  | Let { var; body = Var var'; _ } | Let_rec ([var, _], Var var')
+    when Variable.equal var var' ->
+    { copied_lets; extracted_lets;
+      terminator = Flambda_utils.toplevel_substitution substitution expr;
+    }
+  (* If the pattern is what lifting let_rec generates, prevent it from being
+     lifted again. *)
+  | Let_rec (defs,
+             Let { var; body = Var var';
+                   defining_expr = Prim (Pmakeblock _, fields, _); })
+    when
+      Variable.equal var var'
+      && List.for_all (fun field ->
+          List.exists (fun (def_var, _) -> Variable.equal def_var field) defs)
+      fields ->
+    { copied_lets; extracted_lets;
+      terminator = Flambda_utils.toplevel_substitution substitution expr;
+    }
+  | Let { var; defining_expr = Expr (Var alias); body; _ }
+  | Let_rec ([var, Expr (Var alias)], body) ->
+    let alias =
+      match Variable.Map.find alias substitution with
+      | exception Not_found -> alias
+      | original_alias -> original_alias
+    in
+    accumulate
+      ~substitution:(Variable.Map.add var alias substitution)
+      ~copied_lets
+      ~extracted_lets
+      body
+  | Let { var; defining_expr = named; body; _ }
+  | Let_rec ([var, named], body)
+    when should_copy named ->
+      accumulate body
+        ~substitution
+        ~copied_lets:((var, named)::copied_lets)
+        ~extracted_lets
+  | Let { var; defining_expr = named; body; _ } ->
+    let extracted =
+      let renamed = Variable.rename var in
+      match named with
+      | Prim (Pmakeblock (tag, Asttypes.Immutable), args, _dbg) ->
+        let tag = Tag.create_exn tag in
+        let args =
+          List.map (fun v ->
+              try Variable.Map.find v substitution
+              with Not_found -> v)
+            args
+        in
+        Block (var, tag, args)
+      | named ->
+        let expr =
+          Flambda_utils.toplevel_substitution substitution
+            (Flambda.create_let renamed named (Var renamed))
+        in
+        Expr (var, expr)
+    in
+    accumulate body
+      ~substitution
+      ~copied_lets
+      ~extracted_lets:(extracted::extracted_lets)
+  | Let_rec ([var, named], body) ->
+    let renamed = Variable.rename var in
+    let def_substitution = Variable.Map.add var renamed substitution in
+    let expr =
+      Flambda_utils.toplevel_substitution def_substitution
+        (Let_rec ([renamed, named], Var renamed))
+    in
+    let extracted = Expr (var, expr) in
+    accumulate body
+      ~substitution
+      ~copied_lets
+      ~extracted_lets:(extracted::extracted_lets)
+  | Let_rec (defs, body) ->
+    let renamed_defs, def_substitution =
+      List.fold_right (fun (var, def) (acc, substitution) ->
+          let new_var = Variable.rename var in
+          (new_var, def) :: acc,
+          Variable.Map.add var new_var substitution)
+        defs ([], substitution)
+    in
+    let extracted =
+      let expr =
+        Flambda_utils.toplevel_substitution def_substitution
+          (Let_rec (renamed_defs,
+                    Flambda_utils.name_expr ~name:"lifted_let_rec_block"
+                      (Prim (Pmakeblock (0, Immutable),
+                             List.map fst renamed_defs,
+                             Debuginfo.none))))
+      in
+      Exprs (List.map fst defs, expr)
+    in
+    accumulate body
+      ~substitution
+      ~copied_lets
+      ~extracted_lets:(extracted::extracted_lets)
+  | _ ->
+  { copied_lets;
+    extracted_lets;
+    terminator = Flambda_utils.toplevel_substitution substitution expr;
+  }
+
+let rebuild_expr
+      ~(extracted_definitions : (Symbol.t * int list) Variable.Map.t)
+      ~(copied_definitions : Flambda.named Variable.Map.t)
+      ~(substitute : bool)
+      (expr : Flambda.t) =
+  let expr_with_read_symbols =
+    Flambda_utils.substitute_read_symbol_field_for_variables
+      extracted_definitions expr
+  in
+  let free_variables = Flambda.free_variables expr_with_read_symbols in
+  let substitution =
+    if substitute then
+      Variable.Map.of_set (fun x -> Variable.rename x) free_variables
+    else
+      Variable.Map.of_set (fun x -> x) free_variables
+  in
+  let expr_with_read_symbols =
+    Flambda_utils.toplevel_substitution substitution
+      expr_with_read_symbols
+  in
+  Variable.Map.fold (fun var declaration body ->
+      let definition = Variable.Map.find var copied_definitions in
+      Flambda.create_let declaration definition body)
+    substitution expr_with_read_symbols
+
+let rebuild (used_variables:Variable.Set.t) (accumulated:accumulated) =
+  let copied_definitions = Variable.Map.of_list accumulated.copied_lets in
+  let accumulated_extracted_lets =
+    List.map (fun decl ->
+        match decl with
+        | Block (var, _, _) | Expr (var, _) ->
+          Flambda_utils.make_variable_symbol var, decl
+        | Exprs (vars, _) ->
+          Flambda_utils.make_variables_symbol vars, decl)
+      accumulated.extracted_lets
+  in
+  let extracted_definitions =
+    (* Blocks are lifted to direct top-level Initialize_block:
+         accessing the value be done directly through the symbol.
+       Other let bound variables are initialized inside a size
+       one static block:
+         accessing the value is done directly through the field 0
+         of the symbol.
+       let rec of size more than one is represented as a block of
+       all the bound variables allocated inside a size one static
+       block:
+         accessing the value is done directly through the right
+         field of the field 0 of the symbol. *)
+    List.fold_left (fun map (symbol, decl) ->
+        match decl with
+        | Block (var, _tag, _fields) ->
+          Variable.Map.add var (symbol, []) map
+        | Expr (var, _expr) ->
+          Variable.Map.add var (symbol, [0]) map
+        | Exprs (vars, _expr) ->
+          let map, _ =
+            List.fold_left (fun (map, field) var ->
+                Variable.Map.add var (symbol, [field; 0]) map,
+                field + 1)
+              (map, 0) vars
+          in
+          map)
+      Variable.Map.empty accumulated_extracted_lets
+  in
+  let extracted =
+    List.map (fun (symbol, decl) ->
+        match decl with
+        | Expr (var, decl) ->
+          let expr =
+            rebuild_expr ~extracted_definitions ~copied_definitions
+              ~substitute:true decl
+          in
+          if Variable.Set.mem var used_variables then
+            Initialisation
+              (symbol,
+               Tag.create_exn 0,
+               [expr])
+          else
+            Effect expr
+        | Exprs (_vars, decl) ->
+          let expr =
+            rebuild_expr ~extracted_definitions ~copied_definitions
+              ~substitute:true decl
+          in
+          Initialisation (symbol, Tag.create_exn 0, [expr])
+        | Block (_var, tag, fields) ->
+          let fields =
+            List.map (fun var ->
+                rebuild_expr ~extracted_definitions ~copied_definitions
+                  ~substitute:true (Var var))
+              fields
+          in
+          Initialisation (symbol, tag, fields))
+      accumulated_extracted_lets
+  in
+  let terminator =
+    (* We don't need to substitute the variables in the terminator, we
+       suppose that we did for every other occurrence.  Avoiding this
+       substitution allows this transformation to be idempotent. *)
+    rebuild_expr ~extracted_definitions ~copied_definitions
+      ~substitute:false accumulated.terminator
+  in
+  List.rev extracted, terminator
+
+let introduce_symbols expr =
+  let accumulated =
+    accumulate expr
+      ~substitution:Variable.Map.empty
+      ~copied_lets:[] ~extracted_lets:[]
+  in
+  let used_variables = Flambda.used_variables expr in
+  let extracted, terminator = rebuild used_variables accumulated in
+  extracted, terminator
+
+let add_extracted introduced program =
+  List.fold_right (fun extracted program ->
+      match extracted with
+      | Initialisation (symbol, tag, def) ->
+        Flambda.Initialize_symbol (symbol, tag, def, program)
+      | Effect effect ->
+        Flambda.Effect (effect, program))
+    introduced program
+
+let rec split_program (program : Flambda.program_body) : Flambda.program_body =
+  match program with
+  | End s -> End s
+  | Let_symbol (s, def, program) ->
+    Let_symbol (s, def, split_program program)
+  | Let_rec_symbol (defs, program) ->
+    Let_rec_symbol (defs, split_program program)
+  | Effect (expr, program) ->
+    let program = split_program program in
+    let introduced, expr = introduce_symbols expr in
+    add_extracted introduced (Flambda.Effect (expr, program))
+  | Initialize_symbol (symbol, tag, ((_::_::_) as fields), program) ->
+    (* CR-someday pchambart: currently the only initialize_symbol with more
+       than 1 field is the module block. This could evolve, in that case
+       this pattern should be handled properly. *)
+    Initialize_symbol (symbol, tag, fields, split_program program)
+  | Initialize_symbol (sym, tag, [], program) ->
+    Let_symbol (sym, Block (tag, []), split_program program)
+  | Initialize_symbol (symbol, tag, [field], program) ->
+    let program = split_program program in
+    let introduced, field = introduce_symbols field in
+    add_extracted introduced
+      (Flambda.Initialize_symbol (symbol, tag, [field], program))
+
+let lift ~backend:_ (program : Flambda.program) =
+  { program with
+    program_body = split_program program.program_body;
+  }

middle_end/lift_let_to_initialize_symbol.mli

@@ -0,0 +1,36 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Lift toplevel [Let]-expressions to Flambda [program] constructions such
+    that the results of evaluation of such expressions may be accessed
+    directly, through symbols, rather than through closures.  The
+    [Let]-expressions typically come from the compilation of modules (using
+    the bytecode strategy) in [Translmod].
+
+    This means of compilation supercedes the old "transl_store_" methodology
+    for native code.
+
+    An [Initialize_symbol] construction generated by this pass may be
+    subsequently rewritten to [Let_symbol] if it is discovered that the
+    initializer is in fact constant.  (See [Initialize_symbol_to_let_symbol].)
+
+    The [program] constructions generated by this pass will be joined by
+    others that arise from the lifting of constants (see [Lift_constants]).
+*)
+val lift
+   : backend:(module Backend_intf.S)
+  -> Flambda.program
+  -> Flambda.program

middle_end/middle_end.ml

@@ -0,0 +1,162 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+let _dump_function_sizes flam ~backend =
+  let module Backend = (val backend : Backend_intf.S) in
+  let than = max_int in
+  Flambda_iterators.iter_on_set_of_closures_of_program flam
+    ~f:(fun ~constant:_ (set_of_closures : Flambda.set_of_closures) ->
+      Variable.Map.iter (fun fun_var
+            (function_decl : Flambda.function_declaration) ->
+          let closure_id = Closure_id.wrap fun_var in
+          let symbol = Backend.closure_symbol closure_id in
+          match Inlining_cost.lambda_smaller' function_decl.body ~than with
+          | Some size -> Format.eprintf "%a %d\n" Symbol.print symbol size
+          | None -> assert false)
+        set_of_closures.function_decls.funs)
+
+let middle_end ppf ~source_provenance ~prefixname ~backend
+    ~size
+    ~module_ident
+    ~module_initializer =
+  let pass_number = ref 0 in
+  let round_number = ref 0 in
+  let check flam =
+    if !Clflags.flambda_invariant_checks then begin
+      try Flambda_invariants.check_exn flam
+      with exn ->
+        Misc.fatal_errorf "After Flambda pass %d, round %d:@.%s:@.%a"
+          !pass_number !round_number (Printexc.to_string exn)
+          Flambda.print_program flam
+    end
+  in
+  let dump_and_check s flam =
+    if !Clflags.dump_flambda
+    then Format.fprintf ppf "%s:@ %a@." s Flambda.print_program flam;
+    check flam
+  in
+  let (+-+) flam (name, pass) =
+    incr pass_number;
+    if !Clflags.dump_flambda_verbose then begin
+      Format.fprintf ppf "@.PASS: %s@." name;
+      if !Clflags.flambda_invariant_checks then begin
+        Format.fprintf ppf "Before pass %d, round %d:@ %a@." !pass_number
+          !round_number Flambda.print_program flam;
+        Format.eprintf "\n@?"
+      end;
+    end;
+    let timing_pass = (Timings.Flambda_pass (name, source_provenance)) in
+    let flam = Timings.accumulate_time timing_pass pass flam in
+    if !Clflags.flambda_invariant_checks then begin
+      Timings.accumulate_time (Flambda_pass ("check", source_provenance)) check flam
+    end;
+    flam
+  in
+  Timings.accumulate_time (Flambda_pass ("middle_end", source_provenance)) (fun () ->
+    let flam =
+      let timing_pass =
+        Timings.Flambda_pass ("closure_conversion", source_provenance)
+      in
+      Timings.accumulate_time timing_pass (fun () ->
+          module_initializer
+          |> Closure_conversion.lambda_to_flambda ~backend ~module_ident ~size)
+        ()
+    in
+    dump_and_check "After closure conversion" flam;
+    let fast_mode flam =
+      pass_number := 0;
+      let round = 0 in
+      flam
+      +-+ ("lift_lets 1", Lift_code.lift_lets)
+      +-+ ("Lift_constants", Lift_constants.lift_constants ~backend)
+      +-+ ("Share_constants", Share_constants.share_constants)
+      +-+ ("Lift_let_to_initialize_symbol",
+           Lift_let_to_initialize_symbol.lift ~backend)
+      +-+ ("Inline_and_simplify",
+           Inline_and_simplify.run ~never_inline:false ~backend
+             ~prefixname ~round)
+      +-+ ("Ref_to_variables",
+           Ref_to_variables.eliminate_ref)
+      +-+ ("Remove_unused_closure_vars 2",
+           Remove_unused_closure_vars.remove_unused_closure_variables)
+      +-+ ("Initialize_symbol_to_let_symbol",
+           Initialize_symbol_to_let_symbol.run)
+    in
+    let rec loop flam =
+      pass_number := 0;
+      let round = !round_number in
+      incr round_number;
+      if !round_number > !Clflags.simplify_rounds then flam
+      else
+        flam
+        (* Beware: [Lift_constants] must be run before any pass that might
+           duplicate strings. *)
+        +-+ ("lift_lets 1", Lift_code.lift_lets)
+        +-+ ("Lift_constants", Lift_constants.lift_constants ~backend)
+        +-+ ("Share_constants", Share_constants.share_constants)
+        +-+ ("Remove_unused_program_constructs",
+             Remove_unused_program_constructs.remove_unused_program_constructs)
+        +-+ ("Lift_let_to_initialize_symbol",
+             Lift_let_to_initialize_symbol.lift ~backend)
+        +-+ ("lift_lets 2", Lift_code.lift_lets)
+        +-+ ("Remove_unused_closure_vars 1",
+             Remove_unused_closure_vars.remove_unused_closure_variables)
+        +-+ ("Inline_and_simplify",
+             Inline_and_simplify.run ~never_inline:false ~backend
+               ~prefixname ~round)
+        +-+ ("Remove_unused_closure_vars 2",
+             Remove_unused_closure_vars.remove_unused_closure_variables)
+        +-+ ("lift_lets 3", Lift_code.lift_lets)
+        +-+ ("Ref_to_variables",
+             Ref_to_variables.eliminate_ref)
+        +-+ ("Inline_and_simplify noinline",
+             Inline_and_simplify.run ~never_inline:true ~backend
+              ~prefixname ~round)
+        +-+ ("Initialize_symbol_to_let_symbol",
+             Initialize_symbol_to_let_symbol.run)
+        |> loop
+    in
+    let back_end flam =
+      flam
+      +-+ ("Lift_constants", Lift_constants.lift_constants ~backend)
+      +-+ ("Share_constants", Share_constants.share_constants)
+      +-+ ("Remove_unused_program_constructs",
+        Remove_unused_program_constructs.remove_unused_program_constructs)
+    in
+    let flam =
+      if !Clflags.classic_inlining then
+        fast_mode flam
+      else
+        loop flam
+    in
+    let flam = back_end flam in
+    (* Check that there aren't any unused "always inline" attributes. *)
+    Flambda_iterators.iter_apply_on_program flam ~f:(fun apply ->
+        match apply.inline with
+        | Default_inline | Never_inline -> ()
+        | Always_inline ->
+          (* CR-someday mshinwell: consider a different error message if
+             this triggers as a result of the propagation of a user's
+             attribute into the second part of an over application
+             (inline_and_simplify.ml line 710). *)
+          Location.prerr_warning (Debuginfo.to_location apply.dbg)
+            (Warnings.Inlining_impossible "[@inlined] attribute was not \
+              used on this function application (the optimizer did not \
+              know what function was being applied)"));
+    dump_and_check "End of middle end" flam;
+    (* CR mshinwell: add -d... option for this *)
+    (* dump_function_sizes flam ~backend; *)
+    flam) ();

middle_end/middle_end.mli

@@ -0,0 +1,27 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Translate Lambda code to Flambda code and then optimize it. *)
+
+val middle_end
+   : Format.formatter
+  -> source_provenance:Timings.source_provenance
+  -> prefixname:string
+  -> backend:(module Backend_intf.S)
+  -> size:int
+  -> module_ident:Ident.t
+  -> module_initializer:Lambda.lambda
+  -> Flambda.program

middle_end/ref_to_variables.ml

@@ -0,0 +1,190 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+let rename_var var =
+  Mutable_variable.create
+    (Variable.unique_name var)
+  (* Variable.rename var *)
+  (*   ~current_compilation_unit:(Compilation_unit.get_current_exn ()) *)
+
+let variables_not_used_as_local_reference (tree:Flambda.t) =
+  let set = ref Variable.Set.empty in
+  let rec loop_named (flam : Flambda.named) =
+    match flam with
+    (* Directly used block: does not prevent use as a variable *)
+    | Prim(Pfield _, [_], _)
+    | Prim(Poffsetref _, [_], _) -> ()
+    | Prim(Psetfield _, [_block; v], _) ->
+      (* block is not prevented to be used as a local reference, but v is *)
+      set := Variable.Set.add v !set
+    | Prim(_, _, _)
+    | Symbol _ |Const _ | Allocated_const _ | Read_mutable _
+    | Read_symbol_field _ | Project_closure _
+    | Move_within_set_of_closures _ | Project_var _ ->
+      set := Variable.Set.union !set (Flambda.free_variables_named flam)
+    | Set_of_closures set_of_closures ->
+      set := Variable.Set.union !set (Flambda.free_variables_named flam);
+      Variable.Map.iter (fun _ (function_decl : Flambda.function_declaration) ->
+          loop function_decl.body)
+        set_of_closures.function_decls.funs
+    | Expr e ->
+      loop e
+  and loop (flam : Flambda.t) =
+    match flam with
+    | Let { defining_expr; body; _ } ->
+      loop_named defining_expr;
+      loop body
+    | Let_rec (defs, body) ->
+      List.iter (fun (_var, named) -> loop_named named) defs;
+      loop body
+    | Var v ->
+      set := Variable.Set.add v !set
+    | Let_mutable (_, v, body) ->
+      set := Variable.Set.add v !set;
+      loop body
+    | If_then_else (cond, ifso, ifnot) ->
+      set := Variable.Set.add cond !set;
+      loop ifso;
+      loop ifnot
+    | Switch (cond, { consts; blocks; failaction }) ->
+      set := Variable.Set.add cond !set;
+      List.iter (fun (_, branch) -> loop branch) consts;
+      List.iter (fun (_, branch) -> loop branch) blocks;
+      Misc.may loop failaction
+    | String_switch (cond, branches, default) ->
+      set := Variable.Set.add cond !set;
+      List.iter (fun (_, branch) -> loop branch) branches;
+      Misc.may loop default
+    | Static_catch (_, _, body, handler) ->
+      loop body;
+      loop handler
+    | Try_with (body, _, handler) ->
+      loop body;
+      loop handler
+    | While (cond, body) ->
+      loop cond;
+      loop body
+    | For { bound_var = _; from_value; to_value; direction = _; body; } ->
+      set := Variable.Set.add from_value !set;
+      set := Variable.Set.add to_value !set;
+      loop body
+    | Static_raise (_, args) ->
+      set := Variable.Set.union (Variable.Set.of_list args) !set
+    | Proved_unreachable | Apply _ | Send _ | Assign _ ->
+      set := Variable.Set.union !set (Flambda.free_variables flam)
+  in
+  loop tree;
+  !set
+
+let variables_containing_ref (flam:Flambda.t) =
+  let map = ref Variable.Map.empty in
+  let aux (flam : Flambda.t) =
+    match flam with
+    | Let { var;
+            defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable), l, _);
+          } ->
+      map := Variable.Map.add var (List.length l) !map
+    | _ -> ()
+  in
+  Flambda_iterators.iter aux (fun _ -> ()) flam;
+  !map
+
+let eliminate_ref_of_expr flam =
+  let variables_not_used_as_local_reference =
+    variables_not_used_as_local_reference flam
+  in
+  let convertible_variables =
+    Variable.Map.filter
+      (fun v _ -> not (Variable.Set.mem v variables_not_used_as_local_reference))
+      (variables_containing_ref flam)
+  in
+  if Variable.Map.cardinal convertible_variables = 0 then flam
+  else
+    let convertible_variables =
+      Variable.Map.mapi (fun v size -> Array.init size (fun _ -> rename_var v))
+        convertible_variables
+    in
+    let convertible_variable v = Variable.Map.mem v convertible_variables in
+    let get_variable v field =
+      let arr = try Variable.Map.find v convertible_variables
+        with Not_found -> assert false in
+      if Array.length arr <= field
+      then None (* This case could apply when inlining code containing GADTS *)
+      else Some (arr.(field), Array.length arr)
+    in
+    let aux (flam : Flambda.t) : Flambda.t =
+      match flam with
+      | Let { var;
+              defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable), l, _);
+              body }
+        when convertible_variable var ->
+        let _, expr =
+          List.fold_left (fun (field,body) init ->
+              match get_variable var field with
+              | None -> assert false
+              | Some (field_var, _) ->
+                field+1,
+                ((Let_mutable (field_var, init, body)) : Flambda.t))
+            (0,body) l in
+        expr
+      | Let _ | Let_mutable _
+      | Assign _ | Var _ | Apply _
+      | Let_rec _ | Switch _ | String_switch _
+      | Static_raise _ | Static_catch _
+      | Try_with _ | If_then_else _
+      | While _ | For _ | Send _ | Proved_unreachable ->
+        flam
+    and aux_named (named : Flambda.named) : Flambda.named =
+      match named with
+      | Prim(Pfield field, [v], _)
+        when convertible_variable v ->
+        (match get_variable v field with
+         | None -> Expr Proved_unreachable
+         | Some (var,_) -> Read_mutable var)
+      | Prim(Poffsetref delta, [v], dbg)
+        when convertible_variable v ->
+        (match get_variable v 0 with
+         | None -> Expr Proved_unreachable
+         | Some (var,size) ->
+           if size = 1
+           then begin
+             let mut = Variable.create "read_mutable" in
+             let new_value = Variable.create "offseted" in
+             let expr =
+               Flambda.create_let mut (Read_mutable var)
+                 (Flambda.create_let new_value (Prim(Poffsetint delta, [mut], dbg))
+                    (Assign { being_assigned = var; new_value }))
+             in
+             Expr expr
+           end
+           else
+             Expr Proved_unreachable)
+      | Prim(Psetfield (field, _, _), [v; new_value], _)
+        when convertible_variable v ->
+        (match get_variable v field with
+         | None -> Expr Proved_unreachable
+         | Some (being_assigned,_) ->
+           Expr (Assign { being_assigned; new_value }))
+      | Prim _ | Symbol _ | Const _ | Allocated_const _ | Read_mutable _
+      | Read_symbol_field _ | Set_of_closures _ | Project_closure _
+      | Move_within_set_of_closures _ | Project_var _ | Expr _ ->
+        named
+    in
+    Flambda_iterators.map aux aux_named flam
+
+let eliminate_ref (program:Flambda.program) =
+  Flambda_iterators.map_exprs_at_toplevel_of_program program
+    ~f:eliminate_ref_of_expr

middle_end/ref_to_variables.mli

@@ -0,0 +1,21 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Transform [let]-bound references into variables. *)
+
+val eliminate_ref
+   : Flambda.program
+  -> Flambda.program

middle_end/remove_unused_arguments.ml

@@ -0,0 +1,174 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+let rename_var var =
+  Variable.rename var
+    ~current_compilation_unit:(Compilation_unit.get_current_exn ())
+
+let remove_params unused (fun_decl: Flambda.function_declaration) =
+  let unused_params, used_params =
+    List.partition (fun v -> Variable.Set.mem v unused) fun_decl.params
+  in
+  let unused_params = List.filter (fun v ->
+      Variable.Set.mem v fun_decl.free_variables) unused_params
+  in
+  let body =
+    List.fold_left (fun body var ->
+        Flambda.create_let var (Const (Const_pointer 0)) body)
+      fun_decl.body
+      unused_params
+  in
+  Flambda.create_function_declaration ~params:used_params ~body
+    ~stub:fun_decl.stub ~dbg:fun_decl.dbg ~inline:fun_decl.inline
+    ~is_a_functor:fun_decl.is_a_functor
+
+let make_stub unused var (fun_decl : Flambda.function_declaration)
+    ~specialised_args ~additional_specialised_args =
+  let renamed = rename_var var in
+  let args' =
+    List.map (fun var -> var, rename_var var) fun_decl.params
+  in
+  let used_args' =
+    List.filter (fun (var, _) -> not (Variable.Set.mem var unused)) args'
+  in
+  let additional_specialised_args =
+    List.fold_left (fun additional_specialised_args (original_arg,arg) ->
+        match Variable.Map.find original_arg specialised_args with
+        | exception Not_found -> additional_specialised_args
+        | outside_var ->
+          Variable.Map.add arg outside_var additional_specialised_args)
+      additional_specialised_args used_args'
+  in
+  let args = List.map (fun (_, var) -> var) used_args' in
+  let kind = Flambda.Direct (Closure_id.wrap renamed) in
+  let dbg = fun_decl.dbg in
+  let body : Flambda.t =
+    Apply {
+      func = renamed;
+      args;
+      kind;
+      dbg;
+      inline = Default_inline;
+    }
+  in
+  let function_decl =
+    Flambda.create_function_declaration ~params:(List.map snd args') ~body
+      ~stub:true ~dbg:fun_decl.dbg ~inline:fun_decl.inline
+      ~is_a_functor:fun_decl.is_a_functor
+  in
+  function_decl, renamed, additional_specialised_args
+
+let separate_unused_arguments (set_of_closures : Flambda.set_of_closures) =
+  let function_decls = set_of_closures.function_decls in
+  let unused = Invariant_params.unused_arguments function_decls in
+  let non_stub_arguments =
+    Variable.Map.fold (fun _ (decl : Flambda.function_declaration) acc ->
+        if decl.stub then
+          acc
+        else
+          Variable.Set.union acc (Variable.Set.of_list decl.Flambda.params))
+      function_decls.funs Variable.Set.empty
+  in
+  let unused = Variable.Set.inter non_stub_arguments unused in
+  if Variable.Set.is_empty unused
+  then None
+  else begin
+    let funs, additional_specialised_args =
+      Variable.Map.fold (fun fun_id (fun_decl : Flambda.function_declaration)
+                          (funs, additional_specialised_args) ->
+          if List.exists (fun v -> Variable.Set.mem v unused) fun_decl.params
+          then begin
+            let stub, renamed_fun_id, additional_specialised_args =
+              make_stub unused fun_id fun_decl
+                ~specialised_args:set_of_closures.specialised_args
+                ~additional_specialised_args
+            in
+            let cleaned = remove_params unused fun_decl in
+            Variable.Map.add fun_id stub
+              (Variable.Map.add renamed_fun_id cleaned funs),
+            additional_specialised_args
+          end
+          else
+            Variable.Map.add fun_id fun_decl funs,
+            additional_specialised_args
+        )
+        function_decls.funs (Variable.Map.empty, Variable.Map.empty)
+    in
+    let specialised_args =
+      Variable.Map.disjoint_union additional_specialised_args
+        (Variable.Map.filter (fun param _ -> not (Variable.Set.mem param unused))
+           set_of_closures.specialised_args)
+    in
+    let function_decls =
+      Flambda.update_function_declarations function_decls ~funs
+    in
+    let set_of_closures =
+      Flambda.create_set_of_closures ~function_decls
+        ~free_vars:set_of_closures.free_vars ~specialised_args
+    in
+    Some set_of_closures
+  end
+
+(* Spliting is not always beneficial. For instance when a function
+   is only indirectly called, suppressing unused arguments does not
+   benefit, and introduce an useless intermediate call *)
+let candidate_for_spliting_for_unused_arguments
+    (fun_decls : Flambda.function_declarations)
+    ~backend =
+  if not !Clflags.remove_unused_arguments then begin
+    false
+  end else begin
+    let no_recursive_functions =
+      Variable.Set.is_empty
+        (Find_recursive_functions.in_function_declarations fun_decls ~backend)
+    in
+    let number_of_non_stub_functions =
+      Variable.Map.cardinal
+        (Variable.Map.filter (fun _ { Flambda.stub } -> not stub)
+           fun_decls.funs)
+    in
+    (not no_recursive_functions) || (number_of_non_stub_functions > 1)
+  end
+
+let separate_unused_arguments_in_set_of_closures set_of_closures ~backend =
+  if candidate_for_spliting_for_unused_arguments
+      set_of_closures.Flambda.function_decls
+      ~backend
+  then match separate_unused_arguments set_of_closures with
+    | None -> set_of_closures
+    | Some set_of_closures -> set_of_closures
+  else set_of_closures
+
+let separate_unused_arguments_in_closures_expr tree ~backend =
+  let aux_named (named : Flambda.named) : Flambda.named =
+    match named with
+    | Set_of_closures set_of_closures ->
+      if candidate_for_spliting_for_unused_arguments
+          set_of_closures.function_decls ~backend
+      then begin
+        match separate_unused_arguments set_of_closures with
+        | None -> named
+        | Some set_of_closures -> Set_of_closures set_of_closures
+      end else begin
+        named
+      end
+    | e -> e
+  in
+  Flambda_iterators.map_named aux_named tree
+
+let separate_unused_arguments_in_closures program ~backend =
+  Flambda_iterators.map_exprs_at_toplevel_of_program program ~f:(fun expr ->
+    separate_unused_arguments_in_closures_expr expr ~backend)

middle_end/remove_unused_arguments.mli

@@ -0,0 +1,37 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Introduce a stub function to avoid depending on unused arguments.
+
+    For instance, it turns
+      [let rec fact n unused =
+         if n = 0 then 1
+         else n * fact (n-1) unused]
+    into
+      [let rec fact' n =
+         if n = 0 then 1
+         else n * fact' (n-1)
+       and fact n unused = fact' n]
+*)
+val separate_unused_arguments_in_closures
+   : Flambda.program
+  -> backend:(module Backend_intf.S)
+  -> Flambda.program
+
+val separate_unused_arguments_in_set_of_closures
+   : Flambda.set_of_closures
+  -> backend:(module Backend_intf.S)
+  -> Flambda.set_of_closures

middle_end/remove_unused_closure_vars.ml

@@ -0,0 +1,85 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                OCaml                                   *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2013--2016 OCamlPro SAS                                    *)
+(*   Copyright 2014--2016 Jane Street Group LLC                           *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Library General Public License version 2.1, with the         *)
+(*   special exception on linking described in the file ../LICENSE.       *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** A variable in a closure can either be used by the closure itself
+    or by an inlined version of the function. *)
+let remove_unused_closure_variables program =
+  let used_vars_within_closure, used_closure_ids =
+    let used = Var_within_closure.Tbl.create 13 in
+    let used_fun = Closure_id.Tbl.create 13 in
+    let aux_named (named : Flambda.named) =
+      match named with
+      | Project_closure { set_of_closures = _; closure_id } ->
+        Closure_id.Tbl.add used_fun closure_id ()
+      | Project_var { closure_id; var } ->
+        Var_within_closure.Tbl.add used var ();
+        Closure_id.Tbl.add used_fun closure_id ()
+      | Move_within_set_of_closures { closure = _; start_from; move_to } ->
+        Closure_id.Tbl.add used_fun start_from ();
+        Closure_id.Tbl.add used_fun move_to ()
+      | Symbol _ | Const _ | Set_of_closures _ | Prim _ | Expr _
+      | Allocated_const _ | Read_mutable _ | Read_symbol_field _ -> ()
+    in
+    Flambda_iterators.iter_named_of_program ~f:aux_named program;
+    used, used_fun
+  in
+  let aux_named _ (named : Flambda.named) : Flambda.named =
+    match named with
+    | Set_of_closures ({ function_decls; free_vars; _ } as set_of_closures) ->
+      let all_free_vars =
+        Variable.Map.fold (fun _ { Flambda. free_variables } acc ->
+            Variable.Set.union free_variables acc)
+          function_decls.funs
+          Variable.Set.empty
+      in
+      let free_vars =
+        Variable.Map.filter (fun id _var ->
+            Variable.Set.mem id all_free_vars
+            || Var_within_closure.Tbl.mem
+                 used_vars_within_closure
+                 (Var_within_closure.wrap id))
+          free_vars
+      in
+      let funs =
+        Variable.Map.filter (fun fun_id _ ->
+            Variable.Set.mem fun_id all_free_vars
+              || Closure_id.Tbl.mem
+                   used_closure_ids
+                   (Closure_id.wrap fun_id))
+          function_decls.funs
+      in
+      let function_decls =
+        Flambda.update_function_declarations function_decls ~funs
+      in
+      let specialised_args =
+        (* Remove specialised args that are used by removed functions *)
+        let all_remaining_arguments =
+          Variable.Map.fold (fun _ { Flambda.params } set ->
+              Variable.Set.union set (Variable.Set.of_list params))
+            funs Variable.Set.empty
+        in
+        Variable.Map.filter (fun arg _ ->
+            Variable.Set.mem arg all_remaining_arguments)
+          set_of_closures.specialised_args
+      in
+      let set_of_closures =
+        Flambda.create_set_of_closures ~function_decls ~free_vars
+          ~specialised_args
+      in
+      Set_of_closures set_of_closures
+    | e -> e
+  in
+  Flambda_iterators.map_named_of_program ~f:aux_named program