Move some middle-end files around (#2281)

* Various file moves in the middle end: this is the first stage of improving separation between the middle end and backend.
* Creation of file_formats/ directory (with associated file moves) to hold the definitions of compilation artifact formats.
* Creation of lambda/ directory (with associated file moves) to hold Lambda language definition files, transformation passes and construction passes from Typedtree.
* Disable (hopefully temporarily) dynlink, debugger and ocamldoc for the dune build.

156 files changed, 7879 insertions, 207 deletions

diff --git a/middle_end/backend_var.ml b/middle_end/backend_var.ml
new file mode 100644
index 0000000000..39af7f6062
--- /dev/null
+++ b/middle_end/backend_var.ml
@@ -0,0 +1,87 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                  Mark Shinwell, Jane Street Europe                     *)
+(*                                                                        *)
+(*   Copyright 2018 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-30-40-41-42"]
+
+include Ident
+
+type backend_var = t
+
+module Provenance = struct
+  type t = {
+    module_path : Path.t;
+    location : Debuginfo.t;
+    original_ident : Ident.t;
+  }
+
+  let print ppf { module_path; location; original_ident; } =
+    Format.fprintf ppf "@[<hov 1>(\
+        @[<hov 1>(module_path@ %a)@]@ \
+        @[<hov 1>(location@ %a)@]@ \
+        @[<hov 1>(original_ident@ %a)@]\
+        )@]"
+      Path.print module_path
+      Debuginfo.print_compact location
+      Ident.print original_ident
+
+  let create ~module_path ~location ~original_ident =
+    { module_path;
+      location;
+      original_ident;
+    }
+
+  let module_path t = t.module_path
+  let location t = t.location
+  let original_ident t = t.original_ident
+end
+
+module With_provenance = struct
+  type t =
+    | Without_provenance of backend_var
+    | With_provenance of {
+        var : backend_var;
+        provenance : Provenance.t;
+      }
+
+  let create ?provenance var =
+    match provenance with
+    | None -> Without_provenance var
+    | Some provenance -> With_provenance { var; provenance; }
+
+  let var t =
+    match t with
+    | Without_provenance var
+    | With_provenance { var; provenance = _; } -> var
+
+  let provenance t =
+    match t with
+    | Without_provenance _ -> None
+    | With_provenance { var = _; provenance; } -> Some provenance
+
+  let name t = name (var t)
+
+  let rename t =
+    let var = rename (var t) in
+    match provenance t with
+    | None -> Without_provenance var
+    | Some provenance -> With_provenance { var; provenance; }
+
+  let print ppf t =
+    match provenance t with
+    | None -> print ppf (var t)
+    | Some provenance ->
+      Format.fprintf ppf "%a[%a]"
+        print (var t)
+        Provenance.print provenance
+end
diff --git a/middle_end/backend_var.mli b/middle_end/backend_var.mli
new file mode 100644
index 0000000000..f236be1e47
--- /dev/null
+++ b/middle_end/backend_var.mli
@@ -0,0 +1,54 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                  Mark Shinwell, Jane Street Europe                     *)
+(*                                                                        *)
+(*   Copyright 2018 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Variables used in the backend, optionally equipped with "provenance"
+    information, used for the emission of debugging information. *)
+
+[@@@ocaml.warning "+a-4-30-40-41-42"]
+
+include module type of struct include Ident end
+
+type backend_var = t
+
+module Provenance : sig
+  type t
+
+  val create
+     : module_path:Path.t
+    -> location:Debuginfo.t
+    -> original_ident:Ident.t
+    -> t
+
+  val module_path : t -> Path.t
+  val location : t -> Debuginfo.t
+  val original_ident : t -> Ident.t
+
+  val print : Format.formatter -> t -> unit
+end
+
+module With_provenance : sig
+  (** Values of type [t] should be used for variables in binding position. *)
+  type t
+
+  val print : Format.formatter -> t -> unit
+
+  val create : ?provenance:Provenance.t -> backend_var -> t
+
+  val var : t -> backend_var
+  val provenance : t -> Provenance.t option
+
+  val name : t -> string
+
+  val rename : t -> t
+end
diff --git a/middle_end/clambda.ml b/middle_end/clambda.ml
new file mode 100644
index 0000000000..406bfbccda
--- /dev/null
+++ b/middle_end/clambda.ml
@@ -0,0 +1,203 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* A variant of the "lambda" code with direct / indirect calls explicit
+   and closures explicit too *)
+
+open Asttypes
+open Lambda
+
+type function_label = string
+
+type ustructured_constant =
+  | Uconst_float of float
+  | Uconst_int32 of int32
+  | Uconst_int64 of int64
+  | Uconst_nativeint of nativeint
+  | Uconst_block of int * uconstant list
+  | Uconst_float_array of float list
+  | Uconst_string of string
+  | Uconst_closure of ufunction list * string * uconstant list
+
+and uconstant =
+  | Uconst_ref of string * ustructured_constant option
+  | Uconst_int of int
+  | Uconst_ptr of int
+
+and uphantom_defining_expr =
+  | Uphantom_const of uconstant
+  | Uphantom_var of Backend_var.t
+  | Uphantom_offset_var of { var : Backend_var.t; offset_in_words : int; }
+  | Uphantom_read_field of { var : Backend_var.t; field : int; }
+  | Uphantom_read_symbol_field of { sym : string; field : int; }
+  | Uphantom_block of { tag : int; fields : Backend_var.t list; }
+
+and ulambda =
+    Uvar of Backend_var.t
+  | Uconst of uconstant
+  | Udirect_apply of function_label * ulambda list * Debuginfo.t
+  | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
+  | Uclosure of ufunction list * ulambda list
+  | Uoffset of ulambda * int
+  | Ulet of mutable_flag * value_kind * Backend_var.With_provenance.t
+      * ulambda * ulambda
+  | Uphantom_let of Backend_var.With_provenance.t
+      * uphantom_defining_expr option * ulambda
+  | Uletrec of (Backend_var.With_provenance.t * ulambda) list * ulambda
+  | Uprim of Clambda_primitives.primitive * ulambda list * Debuginfo.t
+  | Uswitch of ulambda * ulambda_switch * Debuginfo.t
+  | Ustringswitch of ulambda * (string * ulambda) list * ulambda option
+  | Ustaticfail of int * ulambda list
+  | Ucatch of
+      int *
+      (Backend_var.With_provenance.t * value_kind) list *
+      ulambda *
+      ulambda
+  | Utrywith of ulambda * Backend_var.With_provenance.t * ulambda
+  | Uifthenelse of ulambda * ulambda * ulambda
+  | Usequence of ulambda * ulambda
+  | Uwhile of ulambda * ulambda
+  | Ufor of Backend_var.With_provenance.t * ulambda * ulambda
+      * direction_flag * ulambda
+  | Uassign of Backend_var.t * ulambda
+  | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
+  | Uunreachable
+
+and ufunction = {
+  label  : function_label;
+  arity  : int;
+  params : (Backend_var.With_provenance.t * value_kind) list;
+  return : value_kind;
+  body   : ulambda;
+  dbg    : Debuginfo.t;
+  env    : Backend_var.t option;
+}
+
+and ulambda_switch =
+  { us_index_consts: int array;
+    us_actions_consts : ulambda array;
+    us_index_blocks: int array;
+    us_actions_blocks: ulambda array}
+
+(* Description of known functions *)
+
+type function_description =
+  { fun_label: function_label;          (* Label of direct entry point *)
+    fun_arity: int;                     (* Number of arguments *)
+    mutable fun_closed: bool;           (* True if environment not used *)
+    mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option;
+    mutable fun_float_const_prop: bool  (* Can propagate FP consts *)
+  }
+
+(* Approximation of values *)
+
+type value_approximation =
+    Value_closure of function_description * value_approximation
+  | Value_tuple of value_approximation array
+  | Value_unknown
+  | Value_const of uconstant
+  | Value_global_field of string * int
+
+(* Preallocated globals *)
+
+type usymbol_provenance = {
+  original_idents : Ident.t list;
+  module_path : Path.t;
+}
+
+type uconstant_block_field =
+  | Uconst_field_ref of string
+  | Uconst_field_int of int
+
+type preallocated_block = {
+  symbol : string;
+  exported : bool;
+  tag : int;
+  fields : uconstant_block_field option list;
+  provenance : usymbol_provenance option;
+}
+
+type preallocated_constant = {
+  symbol : string;
+  exported : bool;
+  definition : ustructured_constant;
+  provenance : usymbol_provenance option;
+}
+
+(* Comparison functions for constants.  We must not use Stdlib.compare
+   because it compares "0.0" and "-0.0" equal.  (PR#6442) *)
+
+let compare_floats x1 x2 =
+  Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2)
+
+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
+
+let compare_constants c1 c2 =
+  match c1, c2 with
+  | Uconst_ref(lbl1, _c1), Uconst_ref(lbl2, _c2) -> String.compare lbl1 lbl2
+      (* Same labels -> same constants.
+         Different labels -> different constants, even if the contents
+           match, because of string constants that must not be
+           reshared. *)
+  | Uconst_int n1, Uconst_int n2 -> Stdlib.compare n1 n2
+  | Uconst_ptr n1, Uconst_ptr n2 -> Stdlib.compare n1 n2
+  | Uconst_ref _, _ -> -1
+  | Uconst_int _, Uconst_ref _ -> 1
+  | Uconst_int _, Uconst_ptr _ -> -1
+  | Uconst_ptr _, _ -> 1
+
+let rec compare_constant_lists l1 l2 =
+  match l1, l2 with
+  | [], [] -> 0
+  | [], _::_ -> -1
+  | _::_, [] -> 1
+  | h1::t1, h2::t2 ->
+      let c = compare_constants h1 h2 in
+      if c <> 0 then c else compare_constant_lists t1 t2
+
+let rank_structured_constant = function
+  | Uconst_float _ -> 0
+  | Uconst_int32 _ -> 1
+  | Uconst_int64 _ -> 2
+  | Uconst_nativeint _ -> 3
+  | Uconst_block _ -> 4
+  | Uconst_float_array _ -> 5
+  | Uconst_string _ -> 6
+  | Uconst_closure _ -> 7
+
+let compare_structured_constants c1 c2 =
+  match c1, c2 with
+  | Uconst_float x1, Uconst_float x2 -> compare_floats x1 x2
+  | Uconst_int32 x1, Uconst_int32 x2 -> Int32.compare x1 x2
+  | Uconst_int64 x1, Uconst_int64 x2 -> Int64.compare x1 x2
+  | Uconst_nativeint x1, Uconst_nativeint x2 -> Nativeint.compare x1 x2
+  | Uconst_block(t1, l1), Uconst_block(t2, l2) ->
+      let c = t1 - t2 (* no overflow possible here *) in
+      if c <> 0 then c else compare_constant_lists l1 l2
+  | Uconst_float_array l1, Uconst_float_array l2 ->
+      compare_float_lists l1 l2
+  | Uconst_string s1, Uconst_string s2 -> String.compare s1 s2
+  | Uconst_closure (_,lbl1,_), Uconst_closure (_,lbl2,_) ->
+      String.compare lbl1 lbl2
+  | _, _ ->
+    (* no overflow possible here *)
+    rank_structured_constant c1 - rank_structured_constant c2
diff --git a/middle_end/clambda.mli b/middle_end/clambda.mli
new file mode 100644
index 0000000000..ddd0956dee
--- /dev/null
+++ b/middle_end/clambda.mli
@@ -0,0 +1,153 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* A variant of the "lambda" code with direct / indirect calls explicit
+   and closures explicit too *)
+
+open Asttypes
+open Lambda
+
+type function_label = string
+
+type ustructured_constant =
+  | Uconst_float of float
+  | Uconst_int32 of int32
+  | Uconst_int64 of int64
+  | Uconst_nativeint of nativeint
+  | Uconst_block of int * uconstant list
+  | Uconst_float_array of float list
+  | Uconst_string of string
+  | Uconst_closure of ufunction list * string * uconstant list
+
+and uconstant =
+  | Uconst_ref of string * ustructured_constant option
+  | Uconst_int of int
+  | Uconst_ptr of int
+
+and uphantom_defining_expr =
+  | Uphantom_const of uconstant
+  (** The phantom-let-bound variable is a constant. *)
+  | Uphantom_var of Backend_var.t
+  (** The phantom-let-bound variable is an alias for another variable. *)
+  | Uphantom_offset_var of { var : Backend_var.t; offset_in_words : int; }
+  (** The phantom-let-bound-variable's value is defined by adding the given
+      number of words to the pointer contained in the given identifier. *)
+  | Uphantom_read_field of { var : Backend_var.t; field : int; }
+  (** The phantom-let-bound-variable's value is found by adding the given
+      number of words to the pointer contained in the given identifier, then
+      dereferencing. *)
+  | Uphantom_read_symbol_field of { sym : string; field : int; }
+  (** As for [Uphantom_read_var_field], but with the pointer specified by
+      a symbol. *)
+  | Uphantom_block of { tag : int; fields : Backend_var.t list; }
+  (** The phantom-let-bound variable points at a block with the given
+      structure. *)
+
+and ulambda =
+    Uvar of Backend_var.t
+  | Uconst of uconstant
+  | Udirect_apply of function_label * ulambda list * Debuginfo.t
+  | Ugeneric_apply of ulambda * ulambda list * Debuginfo.t
+  | Uclosure of ufunction list * ulambda list
+  | Uoffset of ulambda * int
+  | Ulet of mutable_flag * value_kind * Backend_var.With_provenance.t
+      * ulambda * ulambda
+  | Uphantom_let of Backend_var.With_provenance.t
+      * uphantom_defining_expr option * ulambda
+  | Uletrec of (Backend_var.With_provenance.t * ulambda) list * ulambda
+  | Uprim of Clambda_primitives.primitive * ulambda list * Debuginfo.t
+  | Uswitch of ulambda * ulambda_switch * Debuginfo.t
+  | Ustringswitch of ulambda * (string * ulambda) list * ulambda option
+  | Ustaticfail of int * ulambda list
+  | Ucatch of
+      int *
+      (Backend_var.With_provenance.t * value_kind) list *
+      ulambda *
+      ulambda
+  | Utrywith of ulambda * Backend_var.With_provenance.t * ulambda
+  | Uifthenelse of ulambda * ulambda * ulambda
+  | Usequence of ulambda * ulambda
+  | Uwhile of ulambda * ulambda
+  | Ufor of Backend_var.With_provenance.t * ulambda * ulambda
+      * direction_flag * ulambda
+  | Uassign of Backend_var.t * ulambda
+  | Usend of meth_kind * ulambda * ulambda * ulambda list * Debuginfo.t
+  | Uunreachable
+
+and ufunction = {
+  label  : function_label;
+  arity  : int;
+  params : (Backend_var.With_provenance.t * value_kind) list;
+  return : value_kind;
+  body   : ulambda;
+  dbg    : Debuginfo.t;
+  env    : Backend_var.t option;
+}
+
+and ulambda_switch =
+  { us_index_consts: int array;
+    us_actions_consts: ulambda array;
+    us_index_blocks: int array;
+    us_actions_blocks: ulambda array}
+
+(* Description of known functions *)
+
+type function_description =
+  { fun_label: function_label;          (* Label of direct entry point *)
+    fun_arity: int;                     (* Number of arguments *)
+    mutable fun_closed: bool;           (* True if environment not used *)
+    mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option;
+    mutable fun_float_const_prop: bool  (* Can propagate FP consts *)
+  }
+
+(* Approximation of values *)
+
+type value_approximation =
+    Value_closure of function_description * value_approximation
+  | Value_tuple of value_approximation array
+  | Value_unknown
+  | Value_const of uconstant
+  | Value_global_field of string * int
+
+(* Comparison functions for constants *)
+
+val compare_structured_constants:
+        ustructured_constant -> ustructured_constant -> int
+val compare_constants:
+        uconstant -> uconstant -> int
+
+type usymbol_provenance = {
+  original_idents : Ident.t list;
+  module_path : Path.t;
+}
+
+type uconstant_block_field =
+  | Uconst_field_ref of string
+  | Uconst_field_int of int
+
+type preallocated_block = {
+  symbol : string;
+  exported : bool;
+  tag : int;
+  fields : uconstant_block_field option list;
+  provenance : usymbol_provenance option;
+}
+
+type preallocated_constant = {
+  symbol : string;
+  exported : bool;
+  definition : ustructured_constant;
+  provenance : usymbol_provenance option;
+}
diff --git a/middle_end/clambda_primitives.ml b/middle_end/clambda_primitives.ml
new file mode 100644
index 0000000000..a7c9798f36
--- /dev/null
+++ b/middle_end/clambda_primitives.ml
@@ -0,0 +1,155 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type mutable_flag = Asttypes.mutable_flag
+
+type immediate_or_pointer = Lambda.immediate_or_pointer
+
+type initialization_or_assignment = Lambda.initialization_or_assignment
+
+type is_safe = Lambda.is_safe
+
+type boxed =
+  | Boxed
+  | Unboxed
+
+type memory_access_size =
+  | Sixteen
+  | Thirty_two
+  | Sixty_four
+
+type primitive =
+  | Pread_symbol of string
+  (* Operations on heap blocks *)
+  | Pmakeblock of int * mutable_flag * block_shape
+  | Pfield of int
+  | Pfield_computed
+  | Psetfield of int * immediate_or_pointer * initialization_or_assignment
+  | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
+  | Pfloatfield of int
+  | Psetfloatfield of int * initialization_or_assignment
+  | Pduprecord of Types.record_representation * int
+  (* External call *)
+  | Pccall of Primitive.description
+  (* Exceptions *)
+  | Praise of raise_kind
+  (* Boolean operations *)
+  | Psequand | Psequor | Pnot
+  (* Integer operations *)
+  | Pnegint | Paddint | Psubint | Pmulint
+  | Pdivint of is_safe | Pmodint of is_safe
+  | Pandint | Porint | Pxorint
+  | Plslint | Plsrint | Pasrint
+  | Pintcomp of integer_comparison
+  | Poffsetint of int
+  | Poffsetref of int
+  (* Float operations *)
+  | Pintoffloat | Pfloatofint
+  | Pnegfloat | Pabsfloat
+  | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
+  | Pfloatcomp of float_comparison
+  (* String operations *)
+  | Pstringlength | Pstringrefu  | Pstringrefs
+  | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
+  (* Array operations *)
+  | Pmakearray of array_kind * mutable_flag
+  | Pduparray of array_kind * mutable_flag
+  (** For [Pduparray], the argument must be an immutable array.
+      The arguments of [Pduparray] give the kind and mutability of the
+      array being *produced* by the duplication. *)
+  | Parraylength of array_kind
+  | Parrayrefu of array_kind
+  | Parraysetu of array_kind
+  | Parrayrefs of array_kind
+  | Parraysets of array_kind
+  (* Test if the argument is a block or an immediate integer *)
+  | Pisint
+  (* Test if the (integer) argument is outside an interval *)
+  | Pisout
+  (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
+  | Pbintofint of boxed_integer
+  | Pintofbint of boxed_integer
+  | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*)
+  | Pnegbint of boxed_integer
+  | Paddbint of boxed_integer
+  | Psubbint of boxed_integer
+  | Pmulbint of boxed_integer
+  | Pdivbint of { size : boxed_integer; is_safe : is_safe }
+  | Pmodbint of { size : boxed_integer; is_safe : is_safe }
+  | Pandbint of boxed_integer
+  | Porbint of boxed_integer
+  | Pxorbint of boxed_integer
+  | Plslbint of boxed_integer
+  | Plsrbint of boxed_integer
+  | Pasrbint of boxed_integer
+  | Pbintcomp of boxed_integer * integer_comparison
+  (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *)
+  | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout
+  | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout
+  (* size of the nth dimension of a big array *)
+  | Pbigarraydim of int
+  (* load/set 16,32,64 bits from a string: (unsafe)*)
+  | Pstring_load of (memory_access_size * is_safe)
+  | Pbytes_load of (memory_access_size * is_safe)
+  | Pbytes_set of (memory_access_size * is_safe)
+  (* load/set 16,32,64 bits from a
+     (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
+  | Pbigstring_load of (memory_access_size * is_safe)
+  | Pbigstring_set of (memory_access_size * is_safe)
+  (* byte swap *)
+  | Pbswap16
+  | Pbbswap of boxed_integer
+  (* Integer to external pointer *)
+  | Pint_as_pointer
+  (* Inhibition of optimisation *)
+  | Popaque
+
+and integer_comparison = Lambda.integer_comparison =
+    Ceq | Cne | Clt | Cgt | Cle | Cge
+
+and float_comparison = Lambda.float_comparison =
+    CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge
+
+and array_kind = Lambda.array_kind =
+    Pgenarray | Paddrarray | Pintarray | Pfloatarray
+
+and value_kind = Lambda.value_kind =
+  (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *)
+    Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
+
+and block_shape = Lambda.block_shape
+and boxed_integer = Primitive.boxed_integer =
+    Pnativeint | Pint32 | Pint64
+
+and bigarray_kind = Lambda.bigarray_kind =
+    Pbigarray_unknown
+  | Pbigarray_float32 | Pbigarray_float64
+  | Pbigarray_sint8 | Pbigarray_uint8
+  | Pbigarray_sint16 | Pbigarray_uint16
+  | Pbigarray_int32 | Pbigarray_int64
+  | Pbigarray_caml_int | Pbigarray_native_int
+  | Pbigarray_complex32 | Pbigarray_complex64
+
+and bigarray_layout = Lambda.bigarray_layout =
+    Pbigarray_unknown_layout
+  | Pbigarray_c_layout
+  | Pbigarray_fortran_layout
+
+and raise_kind = Lambda.raise_kind =
+  | Raise_regular
+  | Raise_reraise
+  | Raise_notrace
+
+let equal (x: primitive) (y: primitive) = x = y
diff --git a/middle_end/clambda_primitives.mli b/middle_end/clambda_primitives.mli
new file mode 100644
index 0000000000..d534ca9cfa
--- /dev/null
+++ b/middle_end/clambda_primitives.mli
@@ -0,0 +1,158 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type mutable_flag = Asttypes.mutable_flag
+
+type immediate_or_pointer = Lambda.immediate_or_pointer
+
+type initialization_or_assignment = Lambda.initialization_or_assignment
+
+type is_safe = Lambda.is_safe
+
+type boxed =
+  | Boxed
+  | Unboxed
+
+type memory_access_size =
+  | Sixteen
+  | Thirty_two
+  | Sixty_four
+
+type primitive =
+  | Pread_symbol of string
+  (* Operations on heap blocks *)
+  | Pmakeblock of int * mutable_flag * block_shape
+  | Pfield of int
+  | Pfield_computed
+  | Psetfield of int * immediate_or_pointer * initialization_or_assignment
+  | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
+  | Pfloatfield of int
+  | Psetfloatfield of int * initialization_or_assignment
+  | Pduprecord of Types.record_representation * int
+  (* External call *)
+  | Pccall of Primitive.description
+  (* Exceptions *)
+  | Praise of raise_kind
+  (* Boolean operations *)
+  | Psequand | Psequor | Pnot
+  (* Integer operations *)
+  | Pnegint | Paddint | Psubint | Pmulint
+  | Pdivint of is_safe | Pmodint of is_safe
+  | Pandint | Porint | Pxorint
+  | Plslint | Plsrint | Pasrint
+  | Pintcomp of integer_comparison
+  | Poffsetint of int
+  | Poffsetref of int
+  (* Float operations *)
+  | Pintoffloat | Pfloatofint
+  | Pnegfloat | Pabsfloat
+  | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
+  | Pfloatcomp of float_comparison
+  (* String operations *)
+  | Pstringlength | Pstringrefu  | Pstringrefs
+  | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets
+  (* Array operations *)
+  | Pmakearray of array_kind * mutable_flag
+  (** For [Pmakearray], the list of arguments must not be empty.  The empty
+      array should be represented by a distinguished constant in the middle
+      end. *)
+  | Pduparray of array_kind * mutable_flag
+  (** For [Pduparray], the argument must be an immutable array.
+      The arguments of [Pduparray] give the kind and mutability of the
+      array being *produced* by the duplication. *)
+  | Parraylength of array_kind
+  | Parrayrefu of array_kind
+  | Parraysetu of array_kind
+  | Parrayrefs of array_kind
+  | Parraysets of array_kind
+  (* Test if the argument is a block or an immediate integer *)
+  | Pisint
+  (* Test if the (integer) argument is outside an interval *)
+  | Pisout
+  (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
+  | Pbintofint of boxed_integer
+  | Pintofbint of boxed_integer
+  | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*)
+  | Pnegbint of boxed_integer
+  | Paddbint of boxed_integer
+  | Psubbint of boxed_integer
+  | Pmulbint of boxed_integer
+  | Pdivbint of { size : boxed_integer; is_safe : is_safe }
+  | Pmodbint of { size : boxed_integer; is_safe : is_safe }
+  | Pandbint of boxed_integer
+  | Porbint of boxed_integer
+  | Pxorbint of boxed_integer
+  | Plslbint of boxed_integer
+  | Plsrbint of boxed_integer
+  | Pasrbint of boxed_integer
+  | Pbintcomp of boxed_integer * integer_comparison
+  (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *)
+  | Pbigarrayref of bool * int * bigarray_kind * bigarray_layout
+  | Pbigarrayset of bool * int * bigarray_kind * bigarray_layout
+  (* size of the nth dimension of a big array *)
+  | Pbigarraydim of int
+  (* load/set 16,32,64 bits from a string: (unsafe)*)
+  | Pstring_load of (memory_access_size * is_safe)
+  | Pbytes_load of (memory_access_size * is_safe)
+  | Pbytes_set of (memory_access_size * is_safe)
+  (* load/set 16,32,64 bits from a
+     (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
+  | Pbigstring_load of (memory_access_size * is_safe)
+  | Pbigstring_set of (memory_access_size * is_safe)
+  (* byte swap *)
+  | Pbswap16
+  | Pbbswap of boxed_integer
+  (* Integer to external pointer *)
+  | Pint_as_pointer
+  (* Inhibition of optimisation *)
+  | Popaque
+
+and integer_comparison = Lambda.integer_comparison =
+    Ceq | Cne | Clt | Cgt | Cle | Cge
+
+and float_comparison = Lambda.float_comparison =
+    CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge
+
+and array_kind = Lambda.array_kind =
+    Pgenarray | Paddrarray | Pintarray | Pfloatarray
+
+and value_kind = Lambda.value_kind =
+  (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *)
+    Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
+
+and block_shape = Lambda.block_shape
+and boxed_integer = Primitive.boxed_integer =
+    Pnativeint | Pint32 | Pint64
+
+and bigarray_kind = Lambda.bigarray_kind =
+    Pbigarray_unknown
+  | Pbigarray_float32 | Pbigarray_float64
+  | Pbigarray_sint8 | Pbigarray_uint8
+  | Pbigarray_sint16 | Pbigarray_uint16
+  | Pbigarray_int32 | Pbigarray_int64
+  | Pbigarray_caml_int | Pbigarray_native_int
+  | Pbigarray_complex32 | Pbigarray_complex64
+
+and bigarray_layout = Lambda.bigarray_layout =
+    Pbigarray_unknown_layout
+  | Pbigarray_c_layout
+  | Pbigarray_fortran_layout
+
+and raise_kind = Lambda.raise_kind =
+  | Raise_regular
+  | Raise_reraise
+  | Raise_notrace
+
+val equal : primitive -> primitive -> bool
diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml
new file mode 100644
index 0000000000..20767f623f
--- /dev/null
+++ b/middle_end/closure/closure.ml
@@ -0,0 +1,1472 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Introduction of closures, uncurrying, recognition of direct calls *)
+
+open Misc
+open Asttypes
+open Primitive
+open Lambda
+open Switch
+open Clambda
+module P = Clambda_primitives
+
+module Int = Numbers.Int
+module Storer =
+  Switch.Store
+    (struct
+      type t = lambda
+      type key = lambda
+      let make_key =  Lambda.make_key
+      let compare_key = Stdlib.compare
+    end)
+
+module V = Backend_var
+module VP = Backend_var.With_provenance
+
+(* The current backend *)
+
+let no_phantom_lets () =
+  Misc.fatal_error "Closure does not support phantom let generation"
+
+(* Auxiliaries for compiling functions *)
+
+let rec split_list n l =
+  if n <= 0 then ([], l) else begin
+    match l with
+      [] -> fatal_error "Closure.split_list"
+    | a::l -> let (l1, l2) = split_list (n-1) l in (a::l1, l2)
+  end
+
+let rec build_closure_env env_param pos = function
+    [] -> V.Map.empty
+  | id :: rem ->
+      V.Map.add id
+        (Uprim(P.Pfield pos, [Uvar env_param], Debuginfo.none))
+          (build_closure_env env_param (pos+1) rem)
+
+(* Auxiliary for accessing globals.  We change the name of the global
+   to the name of the corresponding asm symbol.  This is done here
+   and no longer in Cmmgen so that approximations stored in .cmx files
+   contain the right names if the -for-pack option is active. *)
+
+let getglobal dbg id =
+  Uprim(P.Pread_symbol (Compilenv.symbol_for_global id), [], dbg)
+
+(* Check if a variable occurs in a [clambda] term. *)
+
+let occurs_var var u =
+  let rec occurs = function
+      Uvar v -> v = var
+    | Uconst _ -> false
+    | Udirect_apply(_lbl, args, _) -> List.exists occurs args
+    | Ugeneric_apply(funct, args, _) -> occurs funct || List.exists occurs args
+    | Uclosure(_fundecls, clos) -> List.exists occurs clos
+    | Uoffset(u, _ofs) -> occurs u
+    | Ulet(_str, _kind, _id, def, body) -> occurs def || occurs body
+    | Uphantom_let _ -> no_phantom_lets ()
+    | Uletrec(decls, body) ->
+        List.exists (fun (_id, u) -> occurs u) decls || occurs body
+    | Uprim(_p, args, _) -> List.exists occurs args
+    | Uswitch(arg, s, _dbg) ->
+        occurs arg ||
+        occurs_array s.us_actions_consts || occurs_array s.us_actions_blocks
+    | Ustringswitch(arg,sw,d) ->
+        occurs arg ||
+        List.exists (fun (_,e) -> occurs e) sw ||
+        (match d with None -> false | Some d -> occurs d)
+    | Ustaticfail (_, args) -> List.exists occurs args
+    | Ucatch(_, _, body, hdlr) -> occurs body || occurs hdlr
+    | Utrywith(body, _exn, hdlr) -> occurs body || occurs hdlr
+    | Uifthenelse(cond, ifso, ifnot) ->
+        occurs cond || occurs ifso || occurs ifnot
+    | Usequence(u1, u2) -> occurs u1 || occurs u2
+    | Uwhile(cond, body) -> occurs cond || occurs body
+    | Ufor(_id, lo, hi, _dir, body) -> occurs lo || occurs hi || occurs body
+    | Uassign(id, u) -> id = var || occurs u
+    | Usend(_, met, obj, args, _) ->
+        occurs met || occurs obj || List.exists occurs args
+    | Uunreachable -> false
+  and occurs_array a =
+    try
+      for i = 0 to Array.length a - 1 do
+        if occurs a.(i) then raise Exit
+      done;
+      false
+    with Exit ->
+      true
+  in occurs u
+
+(* Determine whether the estimated size of a clambda term is below
+   some threshold *)
+
+let prim_size prim args =
+  let open Clambda_primitives in
+  match prim with
+  | Pread_symbol _ -> 1
+  | Pmakeblock _ -> 5 + List.length args
+  | Pfield _ -> 1
+  | Psetfield(_f, isptr, init) ->
+    begin match init with
+    | Root_initialization -> 1  (* never causes a write barrier hit *)
+    | Assignment | Heap_initialization ->
+      match isptr with
+      | Pointer -> 4
+      | Immediate -> 1
+    end
+  | Pfloatfield _ -> 1
+  | Psetfloatfield _ -> 1
+  | Pduprecord _ -> 10 + List.length args
+  | Pccall p -> (if p.prim_alloc then 10 else 4) + List.length args
+  | Praise _ -> 4
+  | Pstringlength -> 5
+  | Pbyteslength -> 5
+  | Pstringrefs  -> 6
+  | Pbytesrefs | Pbytessets -> 6
+  | Pmakearray _ -> 5 + List.length args
+  | Parraylength kind -> if kind = Pgenarray then 6 else 2
+  | Parrayrefu kind -> if kind = Pgenarray then 12 else 2
+  | Parraysetu kind -> if kind = Pgenarray then 16 else 4
+  | Parrayrefs kind -> if kind = Pgenarray then 18 else 8
+  | Parraysets kind -> if kind = Pgenarray then 22 else 10
+  | Pbigarrayref(_, ndims, _, _) -> 4 + ndims * 6
+  | Pbigarrayset(_, ndims, _, _) -> 4 + ndims * 6
+  | _ -> 2 (* arithmetic and comparisons *)
+
+(* Very raw approximation of switch cost *)
+
+let lambda_smaller lam threshold =
+  let size = ref 0 in
+  let rec lambda_size lam =
+    if !size > threshold then raise Exit;
+    match lam with
+      Uvar _ -> ()
+    | Uconst _ -> incr size
+    | Udirect_apply(_, args, _) ->
+        size := !size + 4; lambda_list_size args
+    | Ugeneric_apply(fn, args, _) ->
+        size := !size + 6; lambda_size fn; lambda_list_size args
+    | Uclosure _ ->
+        raise Exit (* inlining would duplicate function definitions *)
+    | Uoffset(lam, _ofs) ->
+        incr size; lambda_size lam
+    | Ulet(_str, _kind, _id, lam, body) ->
+        lambda_size lam; lambda_size body
+    | Uphantom_let _ -> no_phantom_lets ()
+    | Uletrec _ ->
+        raise Exit (* usually too large *)
+    | Uprim(prim, args, _) ->
+        size := !size + prim_size prim args;
+        lambda_list_size args
+    | Uswitch(lam, cases, _dbg) ->
+        if Array.length cases.us_actions_consts > 1 then size := !size + 5 ;
+        if Array.length cases.us_actions_blocks > 1 then size := !size + 5 ;
+        lambda_size lam;
+        lambda_array_size cases.us_actions_consts ;
+        lambda_array_size cases.us_actions_blocks
+    | Ustringswitch (lam,sw,d) ->
+        lambda_size lam ;
+       (* as ifthenelse *)
+        List.iter
+          (fun (_,lam) ->
+            size := !size+2 ;
+            lambda_size lam)
+          sw ;
+        Misc.may lambda_size d
+    | Ustaticfail (_,args) -> lambda_list_size args
+    | Ucatch(_, _, body, handler) ->
+        incr size; lambda_size body; lambda_size handler
+    | Utrywith(body, _id, handler) ->
+        size := !size + 8; lambda_size body; lambda_size handler
+    | Uifthenelse(cond, ifso, ifnot) ->
+        size := !size + 2;
+        lambda_size cond; lambda_size ifso; lambda_size ifnot
+    | Usequence(lam1, lam2) ->
+        lambda_size lam1; lambda_size lam2
+    | Uwhile(cond, body) ->
+        size := !size + 2; lambda_size cond; lambda_size body
+    | Ufor(_id, low, high, _dir, body) ->
+        size := !size + 4; lambda_size low; lambda_size high; lambda_size body
+    | Uassign(_id, lam) ->
+        incr size;  lambda_size lam
+    | Usend(_, met, obj, args, _) ->
+        size := !size + 8;
+        lambda_size met; lambda_size obj; lambda_list_size args
+    | Uunreachable -> ()
+  and lambda_list_size l = List.iter lambda_size l
+  and lambda_array_size a = Array.iter lambda_size a in
+  try
+    lambda_size lam; !size <= threshold
+  with Exit ->
+    false
+
+let is_pure_prim p =
+  let open Semantics_of_primitives in
+  match Semantics_of_primitives.for_primitive p with
+  | (No_effects | Only_generative_effects), _ -> true
+  | Arbitrary_effects, _ -> false
+
+(* Check if a clambda term is ``pure'',
+   that is without side-effects *and* not containing function definitions *)
+
+let rec is_pure = function
+    Uvar _ -> true
+  | Uconst _ -> true
+  | Uprim(p, args, _) -> is_pure_prim p && List.for_all is_pure args
+  | Uoffset(arg, _) -> is_pure arg
+  | Ulet(Immutable, _, _var, def, body) ->
+      is_pure def && is_pure body
+  | _ -> false
+
+(* Simplify primitive operations on known arguments *)
+
+let make_const c = (Uconst c, Value_const c)
+let make_const_ref c =
+  make_const(Uconst_ref(Compilenv.new_structured_constant ~shared:true c,
+    Some c))
+let make_const_int n = make_const (Uconst_int n)
+let make_const_ptr n = make_const (Uconst_ptr n)
+let make_const_bool b = make_const_ptr(if b then 1 else 0)
+
+let make_integer_comparison cmp x y =
+  let open Clambda_primitives in
+  make_const_bool
+    (match cmp with
+       Ceq -> x = y
+     | Cne -> x <> y
+     | Clt -> x < y
+     | Cgt -> x > y
+     | Cle -> x <= y
+     | Cge -> x >= y)
+
+let make_float_comparison cmp x y =
+  make_const_bool
+    (match cmp with
+     | CFeq -> x = y
+     | CFneq -> not (x = y)
+     | CFlt -> x < y
+     | CFnlt -> not (x < y)
+     | CFgt -> x > y
+     | CFngt -> not (x > y)
+     | CFle -> x <= y
+     | CFnle -> not (x <= y)
+     | CFge -> x >= y
+     | CFnge -> not (x >= y))
+
+let make_const_float n = make_const_ref (Uconst_float n)
+let make_const_natint n = make_const_ref (Uconst_nativeint n)
+let make_const_int32 n = make_const_ref (Uconst_int32 n)
+let make_const_int64 n = make_const_ref (Uconst_int64 n)
+
+(* The [fpc] parameter is true if constant propagation of
+   floating-point computations is allowed *)
+
+let simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg =
+  let module B = (val backend : Backend_intf.S) in
+  let open Clambda_primitives in
+  let default = (Uprim(p, args, dbg), Value_unknown) in
+  match approxs with
+  (* int (or enumerated type) *)
+  | [ Value_const(Uconst_int n1 | Uconst_ptr n1) ] ->
+      begin match p with
+      | Pnot -> make_const_bool (n1 = 0)
+      | Pnegint -> make_const_int (- n1)
+      | Poffsetint n -> make_const_int (n + n1)
+      | Pfloatofint when fpc -> make_const_float (float_of_int n1)
+      | Pbintofint Pnativeint -> make_const_natint (Nativeint.of_int n1)
+      | Pbintofint Pint32 -> make_const_int32 (Int32.of_int n1)
+      | Pbintofint Pint64 -> make_const_int64 (Int64.of_int n1)
+      | Pbswap16 -> make_const_int (((n1 land 0xff) lsl 8)
+                                    lor ((n1 land 0xff00) lsr 8))
+      | _ -> default
+      end
+  (* int (or enumerated type), int (or enumerated type) *)
+  | [ Value_const(Uconst_int n1 | Uconst_ptr n1);
+      Value_const(Uconst_int n2 | Uconst_ptr n2) ] ->
+      begin match p with
+      | Psequand -> make_const_bool (n1 <> 0 && n2 <> 0)
+      | Psequor -> make_const_bool (n1 <> 0 || n2 <> 0)
+      | Paddint -> make_const_int (n1 + n2)
+      | Psubint -> make_const_int (n1 - n2)
+      | Pmulint -> make_const_int (n1 * n2)
+      | Pdivint _ when n2 <> 0 -> make_const_int (n1 / n2)
+      | Pmodint _ when n2 <> 0 -> make_const_int (n1 mod n2)
+      | Pandint -> make_const_int (n1 land n2)
+      | Porint -> make_const_int (n1 lor n2)
+      | Pxorint -> make_const_int (n1 lxor n2)
+      | Plslint when 0 <= n2 && n2 < 8 * B.size_int ->
+          make_const_int (n1 lsl n2)
+      | Plsrint when 0 <= n2 && n2 < 8 * B.size_int ->
+          make_const_int (n1 lsr n2)
+      | Pasrint when 0 <= n2 && n2 < 8 * B.size_int ->
+          make_const_int (n1 asr n2)
+      | Pintcomp c -> make_integer_comparison c n1 n2
+      | _ -> default
+      end
+  (* float *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_float n1)))] when fpc ->
+      begin match p with
+      | Pintoffloat -> make_const_int (int_of_float n1)
+      | Pnegfloat -> make_const_float (-. n1)
+      | Pabsfloat -> make_const_float (abs_float n1)
+      | _ -> default
+      end
+  (* float, float *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_float n1)));
+     Value_const(Uconst_ref(_, Some (Uconst_float n2)))] when fpc ->
+      begin match p with
+      | Paddfloat -> make_const_float (n1 +. n2)
+      | Psubfloat -> make_const_float (n1 -. n2)
+      | Pmulfloat -> make_const_float (n1 *. n2)
+      | Pdivfloat -> make_const_float (n1 /. n2)
+      | Pfloatcomp c  -> make_float_comparison c n1 n2
+      | _ -> default
+      end
+  (* nativeint *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n)))] ->
+      begin match p with
+      | Pintofbint Pnativeint -> make_const_int (Nativeint.to_int n)
+      | Pcvtbint(Pnativeint, Pint32) -> make_const_int32 (Nativeint.to_int32 n)
+      | Pcvtbint(Pnativeint, Pint64) -> make_const_int64 (Int64.of_nativeint n)
+      | Pnegbint Pnativeint -> make_const_natint (Nativeint.neg n)
+      | _ -> default
+      end
+  (* nativeint, nativeint *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1)));
+     Value_const(Uconst_ref(_, Some (Uconst_nativeint n2)))] ->
+      begin match p with
+      | Paddbint Pnativeint -> make_const_natint (Nativeint.add n1 n2)
+      | Psubbint Pnativeint -> make_const_natint (Nativeint.sub n1 n2)
+      | Pmulbint Pnativeint -> make_const_natint (Nativeint.mul n1 n2)
+      | Pdivbint {size=Pnativeint} when n2 <> 0n ->
+          make_const_natint (Nativeint.div n1 n2)
+      | Pmodbint {size=Pnativeint} when n2 <> 0n ->
+          make_const_natint (Nativeint.rem n1 n2)
+      | Pandbint Pnativeint -> make_const_natint (Nativeint.logand n1 n2)
+      | Porbint Pnativeint ->  make_const_natint (Nativeint.logor n1 n2)
+      | Pxorbint Pnativeint -> make_const_natint (Nativeint.logxor n1 n2)
+      | Pbintcomp(Pnativeint, c)  -> make_integer_comparison c n1 n2
+      | _ -> default
+      end
+  (* nativeint, int *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_nativeint n1)));
+     Value_const(Uconst_int n2)] ->
+      begin match p with
+      | Plslbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int ->
+          make_const_natint (Nativeint.shift_left n1 n2)
+      | Plsrbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int ->
+          make_const_natint (Nativeint.shift_right_logical n1 n2)
+      | Pasrbint Pnativeint when 0 <= n2 && n2 < 8 * B.size_int ->
+          make_const_natint (Nativeint.shift_right n1 n2)
+      | _ -> default
+      end
+  (* int32 *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_int32 n)))] ->
+      begin match p with
+      | Pintofbint Pint32 -> make_const_int (Int32.to_int n)
+      | Pcvtbint(Pint32, Pnativeint) -> make_const_natint (Nativeint.of_int32 n)
+      | Pcvtbint(Pint32, Pint64) -> make_const_int64 (Int64.of_int32 n)
+      | Pnegbint Pint32 -> make_const_int32 (Int32.neg n)
+      | _ -> default
+      end
+  (* int32, int32 *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_int32 n1)));
+     Value_const(Uconst_ref(_, Some (Uconst_int32 n2)))] ->
+      begin match p with
+      | Paddbint Pint32 -> make_const_int32 (Int32.add n1 n2)
+      | Psubbint Pint32 -> make_const_int32 (Int32.sub n1 n2)
+      | Pmulbint Pint32 -> make_const_int32 (Int32.mul n1 n2)
+      | Pdivbint {size=Pint32} when n2 <> 0l ->
+          make_const_int32 (Int32.div n1 n2)
+      | Pmodbint {size=Pint32} when n2 <> 0l ->
+          make_const_int32 (Int32.rem n1 n2)
+      | Pandbint Pint32 -> make_const_int32 (Int32.logand n1 n2)
+      | Porbint Pint32 -> make_const_int32 (Int32.logor n1 n2)
+      | Pxorbint Pint32 -> make_const_int32 (Int32.logxor n1 n2)
+      | Pbintcomp(Pint32, c) -> make_integer_comparison c n1 n2
+      | _ -> default
+      end
+  (* int32, int *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_int32 n1)));
+     Value_const(Uconst_int n2)] ->
+      begin match p with
+      | Plslbint Pint32 when 0 <= n2 && n2 < 32 ->
+          make_const_int32 (Int32.shift_left n1 n2)
+      | Plsrbint Pint32 when 0 <= n2 && n2 < 32 ->
+          make_const_int32 (Int32.shift_right_logical n1 n2)
+      | Pasrbint Pint32 when 0 <= n2 && n2 < 32 ->
+          make_const_int32 (Int32.shift_right n1 n2)
+      | _ -> default
+      end
+  (* int64 *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_int64 n)))] ->
+      begin match p with
+      | Pintofbint Pint64 -> make_const_int (Int64.to_int n)
+      | Pcvtbint(Pint64, Pint32) -> make_const_int32 (Int64.to_int32 n)
+      | Pcvtbint(Pint64, Pnativeint) -> make_const_natint (Int64.to_nativeint n)
+      | Pnegbint Pint64 -> make_const_int64 (Int64.neg n)
+      | _ -> default
+      end
+  (* int64, int64 *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_int64 n1)));
+     Value_const(Uconst_ref(_, Some (Uconst_int64 n2)))] ->
+      begin match p with
+      | Paddbint Pint64 -> make_const_int64 (Int64.add n1 n2)
+      | Psubbint Pint64 -> make_const_int64 (Int64.sub n1 n2)
+      | Pmulbint Pint64 -> make_const_int64 (Int64.mul n1 n2)
+      | Pdivbint {size=Pint64} when n2 <> 0L ->
+          make_const_int64 (Int64.div n1 n2)
+      | Pmodbint {size=Pint64} when n2 <> 0L ->
+          make_const_int64 (Int64.rem n1 n2)
+      | Pandbint Pint64 -> make_const_int64 (Int64.logand n1 n2)
+      | Porbint Pint64 -> make_const_int64 (Int64.logor n1 n2)
+      | Pxorbint Pint64 -> make_const_int64 (Int64.logxor n1 n2)
+      | Pbintcomp(Pint64, c) -> make_integer_comparison c n1 n2
+      | _ -> default
+      end
+  (* int64, int *)
+  | [Value_const(Uconst_ref(_, Some (Uconst_int64 n1)));
+     Value_const(Uconst_int n2)] ->
+      begin match p with
+      | Plslbint Pint64 when 0 <= n2 && n2 < 64 ->
+          make_const_int64 (Int64.shift_left n1 n2)
+      | Plsrbint Pint64 when 0 <= n2 && n2 < 64 ->
+          make_const_int64 (Int64.shift_right_logical n1 n2)
+      | Pasrbint Pint64 when 0 <= n2 && n2 < 64 ->
+          make_const_int64 (Int64.shift_right n1 n2)
+      | _ -> default
+      end
+  (* TODO: Pbbswap *)
+  (* Catch-all *)
+  | _ ->
+     default
+
+let field_approx n = function
+  | Value_tuple a when n < Array.length a -> a.(n)
+  | Value_const (Uconst_ref(_, Some (Uconst_block(_, l))))
+    when n < List.length l ->
+      Value_const (List.nth l n)
+  | _ -> Value_unknown
+
+let simplif_prim_pure ~backend fpc p (args, approxs) dbg =
+  let open Clambda_primitives in
+  match p, args, approxs with
+  (* Block construction *)
+  | Pmakeblock(tag, Immutable, _kind), _, _ ->
+      let field = function
+        | Value_const c -> c
+        | _ -> raise Exit
+      in
+      begin try
+        let cst = Uconst_block (tag, List.map field approxs) in
+        let name =
+          Compilenv.new_structured_constant cst ~shared:true
+        in
+        make_const (Uconst_ref (name, Some cst))
+      with Exit ->
+        (Uprim(p, args, dbg), Value_tuple (Array.of_list approxs))
+      end
+  (* Field access *)
+  | Pfield n, _, [ Value_const(Uconst_ref(_, Some (Uconst_block(_, l)))) ]
+    when n < List.length l ->
+      make_const (List.nth l n)
+  | Pfield n, [ Uprim(P.Pmakeblock _, ul, _) ], [approx]
+    when n < List.length ul ->
+      (List.nth ul n, field_approx n approx)
+  (* Strings *)
+  | (Pstringlength | Pbyteslength),
+     _,
+     [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] ->
+      make_const_int (String.length s)
+  (* Kind test *)
+  | Pisint, _, [a1] ->
+      begin match a1 with
+      | Value_const(Uconst_int _ | Uconst_ptr _) -> make_const_bool true
+      | Value_const(Uconst_ref _) -> make_const_bool false
+      | Value_closure _ | Value_tuple _ -> make_const_bool false
+      | _ -> (Uprim(p, args, dbg), Value_unknown)
+      end
+  (* Catch-all *)
+  | _ ->
+      simplif_arith_prim_pure ~backend fpc p (args, approxs) dbg
+
+let simplif_prim ~backend fpc p (args, approxs as args_approxs) dbg =
+  if List.for_all is_pure args
+  then simplif_prim_pure ~backend fpc p args_approxs dbg
+  else
+    (* XXX : always return the same approxs as simplif_prim_pure? *)
+    let approx =
+      match p with
+      | P.Pmakeblock(_, Immutable, _kind) ->
+          Value_tuple (Array.of_list approxs)
+      | _ ->
+          Value_unknown
+    in
+    (Uprim(p, args, dbg), approx)
+
+(* Substitute variables in a [ulambda] term (a body of an inlined function)
+   and perform some more simplifications on integer primitives.
+   Also perform alpha-conversion on let-bound identifiers to avoid
+   clashes with locally-generated identifiers, and refresh raise counts
+   in order to avoid clashes with inlined code from other modules.
+   The variables must not be assigned in the term.
+   This is used to substitute "trivial" arguments for parameters
+   during inline expansion, and also for the translation of let rec
+   over functions. *)
+
+let approx_ulam = function
+    Uconst c -> Value_const c
+  | _ -> Value_unknown
+
+let find_action idxs acts tag =
+  if 0 <= tag && tag < Array.length idxs then begin
+    let idx = idxs.(tag) in
+    assert(0 <= idx && idx < Array.length acts);
+    Some acts.(idx)
+  end else
+    (* Can this happen? *)
+    None
+
+let subst_debuginfo loc dbg =
+  if !Clflags.debug then
+    Debuginfo.inline loc dbg
+  else
+    dbg
+
+let rec substitute loc ((backend, fpc) as st) sb rn ulam =
+  match ulam with
+    Uvar v ->
+      begin try V.Map.find v sb with Not_found -> ulam end
+  | Uconst _ -> ulam
+  | Udirect_apply(lbl, args, dbg) ->
+      let dbg = subst_debuginfo loc dbg in
+      Udirect_apply(lbl, List.map (substitute loc st sb rn) args, dbg)
+  | Ugeneric_apply(fn, args, dbg) ->
+      let dbg = subst_debuginfo loc dbg in
+      Ugeneric_apply(substitute loc st sb rn fn,
+                     List.map (substitute loc st sb rn) args, dbg)
+  | Uclosure(defs, env) ->
+      (* Question: should we rename function labels as well?  Otherwise,
+         there is a risk that function labels are not globally unique.
+         This should not happen in the current system because:
+         - Inlined function bodies contain no Uclosure nodes
+           (cf. function [lambda_smaller])
+         - When we substitute offsets for idents bound by let rec
+           in [close], case [Lletrec], we discard the original
+           let rec body and use only the substituted term. *)
+      Uclosure(defs, List.map (substitute loc st sb rn) env)
+  | Uoffset(u, ofs) -> Uoffset(substitute loc st sb rn u, ofs)
+  | Ulet(str, kind, id, u1, u2) ->
+      let id' = VP.rename id in
+      Ulet(str, kind, id', substitute loc st sb rn u1,
+           substitute loc st
+             (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2)
+  | Uphantom_let _ -> no_phantom_lets ()
+  | Uletrec(bindings, body) ->
+      let bindings1 =
+        List.map (fun (id, rhs) ->
+          (VP.var id, VP.rename id, rhs)) bindings
+      in
+      let sb' =
+        List.fold_right (fun (id, id', _) s ->
+            V.Map.add id (Uvar (VP.var id')) s)
+          bindings1 sb
+      in
+      Uletrec(
+        List.map
+           (fun (_id, id', rhs) -> (id', substitute loc st sb' rn rhs))
+           bindings1,
+        substitute loc st sb' rn body)
+  | Uprim(p, args, dbg) ->
+      let sargs = List.map (substitute loc st sb rn) args in
+      let dbg = subst_debuginfo loc dbg in
+      let (res, _) =
+        simplif_prim ~backend fpc p (sargs, List.map approx_ulam sargs) dbg in
+      res
+  | Uswitch(arg, sw, dbg) ->
+      let sarg = substitute loc st sb rn arg in
+      let action =
+        (* Unfortunately, we cannot easily deal with the
+           case of a constructed block (makeblock) bound to a local
+           identifier.  This would require to keep track of
+           local let bindings (at least their approximations)
+           in this substitute function.
+        *)
+        match sarg with
+        | Uconst (Uconst_ref (_,  Some (Uconst_block (tag, _)))) ->
+            find_action sw.us_index_blocks sw.us_actions_blocks tag
+        | Uconst (Uconst_ptr tag) ->
+            find_action sw.us_index_consts sw.us_actions_consts tag
+        | _ -> None
+      in
+      begin match action with
+      | Some u -> substitute loc st sb rn u
+      | None ->
+          Uswitch(sarg,
+                  { sw with
+                    us_actions_consts =
+                      Array.map (substitute loc st sb rn) sw.us_actions_consts;
+                    us_actions_blocks =
+                      Array.map (substitute loc st sb rn) sw.us_actions_blocks;
+                  },
+                  dbg)
+      end
+  | Ustringswitch(arg,sw,d) ->
+      Ustringswitch
+        (substitute loc st sb rn arg,
+         List.map (fun (s,act) -> s,substitute loc st sb rn act) sw,
+         Misc.may_map (substitute loc st sb rn) d)
+  | Ustaticfail (nfail, args) ->
+      let nfail =
+        match rn with
+        | Some rn ->
+          begin try
+            Int.Map.find nfail rn
+          with Not_found ->
+            fatal_errorf "Closure.split_list: invalid nfail (%d)" nfail
+          end
+        | None -> nfail in
+      Ustaticfail (nfail, List.map (substitute loc st sb rn) args)
+  | Ucatch(nfail, ids, u1, u2) ->
+      let nfail, rn =
+        match rn with
+        | Some rn ->
+          let new_nfail = next_raise_count () in
+          new_nfail, Some (Int.Map.add nfail new_nfail rn)
+        | None -> nfail, rn in
+      let ids' = List.map (fun (id, k) -> VP.rename id, k) ids in
+      let sb' =
+        List.fold_right2
+          (fun (id, _) (id', _) s ->
+             V.Map.add (VP.var id) (Uvar (VP.var id')) s
+          )
+          ids ids' sb
+      in
+      Ucatch(nfail, ids', substitute loc st sb rn u1,
+                          substitute loc st sb' rn u2)
+  | Utrywith(u1, id, u2) ->
+      let id' = VP.rename id in
+      Utrywith(substitute loc st sb rn u1, id',
+               substitute loc st
+                 (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u2)
+  | Uifthenelse(u1, u2, u3) ->
+      begin match substitute loc st sb rn u1 with
+        Uconst (Uconst_ptr n) ->
+          if n <> 0 then
+            substitute loc st sb rn u2
+          else
+            substitute loc st sb rn u3
+      | Uprim(P.Pmakeblock _, _, _) ->
+          substitute loc st sb rn u2
+      | su1 ->
+          Uifthenelse(su1, substitute loc st sb rn u2,
+                           substitute loc st sb rn u3)
+      end
+  | Usequence(u1, u2) ->
+      Usequence(substitute loc st sb rn u1, substitute loc st sb rn u2)
+  | Uwhile(u1, u2) ->
+      Uwhile(substitute loc st sb rn u1, substitute loc st sb rn u2)
+  | Ufor(id, u1, u2, dir, u3) ->
+      let id' = VP.rename id in
+      Ufor(id', substitute loc st sb rn u1, substitute loc st sb rn u2, dir,
+           substitute loc st
+           (V.Map.add (VP.var id) (Uvar (VP.var id')) sb) rn u3)
+  | Uassign(id, u) ->
+      let id' =
+        try
+          match V.Map.find id sb with Uvar i -> i | _ -> assert false
+        with Not_found ->
+          id in
+      Uassign(id', substitute loc st sb rn u)
+  | Usend(k, u1, u2, ul, dbg) ->
+      let dbg = subst_debuginfo loc dbg in
+      Usend(k, substitute loc st sb rn u1, substitute loc st sb rn u2,
+            List.map (substitute loc st sb rn) ul, dbg)
+  | Uunreachable ->
+      Uunreachable
+
+(* Perform an inline expansion *)
+
+let is_simple_argument = function
+  | Uvar _  | Uconst _ -> true
+  | _ -> false
+
+let no_effects = function
+  | Uclosure _ -> true
+  | u -> is_pure u
+
+let rec bind_params_rec loc fpc subst params args body =
+  match (params, args) with
+    ([], []) -> substitute loc fpc subst (Some Int.Map.empty) body
+  | (p1 :: pl, a1 :: al) ->
+      if is_simple_argument a1 then
+        bind_params_rec loc fpc (V.Map.add (VP.var p1) a1 subst)
+          pl al body
+      else begin
+        let p1' = VP.rename p1 in
+        let u1, u2 =
+          match VP.name p1, a1 with
+          | "*opt*", Uprim(P.Pmakeblock(0, Immutable, kind), [a], dbg) ->
+              a, Uprim(P.Pmakeblock(0, Immutable, kind),
+                       [Uvar (VP.var p1')], dbg)
+          | _ ->
+              a1, Uvar (VP.var p1')
+        in
+        let body' =
+          bind_params_rec loc fpc (V.Map.add (VP.var p1) u2 subst)
+            pl al body in
+        if occurs_var (VP.var p1) body then
+          Ulet(Immutable, Pgenval, p1', u1, body')
+        else if no_effects a1 then body'
+        else Usequence(a1, body')
+      end
+  | (_, _) -> assert false
+
+let bind_params loc fpc params args body =
+  (* Reverse parameters and arguments to preserve right-to-left
+     evaluation order (PR#2910). *)
+  bind_params_rec loc fpc V.Map.empty (List.rev params) (List.rev args) body
+
+(* Check if a lambda term is ``pure'',
+   that is without side-effects *and* not containing function definitions *)
+
+let warning_if_forced_inline ~loc ~attribute warning =
+  if attribute = Always_inline then
+    Location.prerr_warning loc
+      (Warnings.Inlining_impossible warning)
+
+(* Generate a direct application *)
+
+let direct_apply ~backend fundesc ufunct uargs ~loc ~attribute =
+  let app_args =
+    if fundesc.fun_closed then uargs else uargs @ [ufunct] in
+  let app =
+    match fundesc.fun_inline, attribute with
+    | _, Never_inline | None, _ ->
+      let dbg = Debuginfo.from_location loc in
+        warning_if_forced_inline ~loc ~attribute
+          "Function information unavailable";
+        Udirect_apply(fundesc.fun_label, app_args, dbg)
+    | Some(params, body), _  ->
+        bind_params loc (backend, fundesc.fun_float_const_prop) params app_args
+          body
+  in
+  (* If ufunct can contain side-effects or function definitions,
+     we must make sure that it is evaluated exactly once.
+     If the function is not closed, we evaluate ufunct as part of the
+     arguments.
+     If the function is closed, we force the evaluation of ufunct first. *)
+  if not fundesc.fun_closed || is_pure ufunct
+  then app
+  else Usequence(ufunct, app)
+
+(* Add [Value_integer] or [Value_constptr] info to the approximation
+   of an application *)
+
+let strengthen_approx appl approx =
+  match approx_ulam appl with
+    (Value_const _) as intapprox ->
+      intapprox
+  | _ -> approx
+
+(* If a term has approximation Value_integer or Value_constptr and is pure,
+   replace it by an integer constant *)
+
+let check_constant_result ulam approx =
+  match approx with
+    Value_const c when is_pure ulam -> make_const c
+  | Value_global_field (id, i) when is_pure ulam ->
+      begin match ulam with
+      | Uprim(P.Pfield _, [Uprim(P.Pread_symbol _, _, _)], _) -> (ulam, approx)
+      | _ ->
+          let glb =
+            Uprim(P.Pread_symbol id, [], Debuginfo.none)
+          in
+          Uprim(P.Pfield i, [glb], Debuginfo.none), approx
+      end
+  | _ -> (ulam, approx)
+
+(* Evaluate an expression with known value for its side effects only,
+   or discard it if it's pure *)
+
+let sequence_constant_expr ulam1 (ulam2, approx2 as res2) =
+  if is_pure ulam1 then res2 else (Usequence(ulam1, ulam2), approx2)
+
+(* Maintain the approximation of the global structure being defined *)
+
+let global_approx = ref([||] : value_approximation array)
+
+(* Maintain the nesting depth for functions *)
+
+let function_nesting_depth = ref 0
+let excessive_function_nesting_depth = 5
+
+(* Uncurry an expression and explicitate closures.
+   Also return the approximation of the expression.
+   The approximation environment [fenv] maps idents to approximations.
+   Idents not bound in [fenv] approximate to [Value_unknown].
+   The closure environment [cenv] maps idents to [ulambda] terms.
+   It is used to substitute environment accesses for free identifiers. *)
+
+exception NotClosed
+
+type env = {
+  backend : (module Backend_intf.S);
+  cenv : ulambda V.Map.t;
+  fenv : value_approximation V.Map.t;
+}
+
+let close_approx_var { fenv; cenv } id =
+  let approx = try V.Map.find id fenv with Not_found -> Value_unknown in
+  match approx with
+    Value_const c -> make_const c
+  | approx ->
+      let subst = try V.Map.find id cenv with Not_found -> Uvar id in
+      (subst, approx)
+
+let close_var env id =
+  let (ulam, _app) = close_approx_var env id in ulam
+
+let rec close ({ backend; fenv; cenv } as env) lam =
+  let module B = (val backend : Backend_intf.S) in
+  match lam with
+  | Lvar id ->
+      close_approx_var env id
+  | Lconst cst ->
+      let str ?(shared = true) cst =
+        let name =
+          Compilenv.new_structured_constant cst ~shared
+        in
+        Uconst_ref (name, Some cst)
+      in
+      let rec transl = function
+        | Const_base(Const_int n) -> Uconst_int n
+        | Const_base(Const_char c) -> Uconst_int (Char.code c)
+        | Const_pointer n -> Uconst_ptr n
+        | Const_block (tag, fields) ->
+            str (Uconst_block (tag, List.map transl fields))
+        | Const_float_array sl ->
+            (* constant float arrays are really immutable *)
+            str (Uconst_float_array (List.map float_of_string sl))
+        | Const_immstring s ->
+            str (Uconst_string s)
+        | Const_base (Const_string (s, _)) ->
+              (* Strings (even literal ones) must be assumed to be mutable...
+                 except when OCaml has been configured with
+                 -safe-string.  Passing -safe-string at compilation
+                 time is not enough, since the unit could be linked
+                 with another one compiled without -safe-string, and
+                 that one could modify our string literal.  *)
+            str ~shared:Config.safe_string (Uconst_string s)
+        | Const_base(Const_float x) -> str (Uconst_float (float_of_string x))
+        | Const_base(Const_int32 x) -> str (Uconst_int32 x)
+        | Const_base(Const_int64 x) -> str (Uconst_int64 x)
+        | Const_base(Const_nativeint x) -> str (Uconst_nativeint x)
+      in
+      make_const (transl cst)
+  | Lfunction _ as funct ->
+      close_one_function env (Ident.create_local "fun") funct
+
+    (* We convert [f a] to [let a' = a in let f' = f in fun b c -> f' a' b c]
+       when fun_arity > nargs *)
+  | Lapply{ap_func = funct; ap_args = args; ap_loc = loc;
+        ap_inlined = attribute} ->
+      let nargs = List.length args in
+      begin match (close env funct, close_list env args) with
+        ((ufunct, Value_closure(fundesc, approx_res)),
+         [Uprim(P.Pmakeblock _, uargs, _)])
+        when List.length uargs = - fundesc.fun_arity ->
+          let app =
+            direct_apply ~backend ~loc ~attribute fundesc ufunct uargs in
+          (app, strengthen_approx app approx_res)
+      | ((ufunct, Value_closure(fundesc, approx_res)), uargs)
+        when nargs = fundesc.fun_arity ->
+          let app =
+            direct_apply ~backend ~loc ~attribute fundesc ufunct uargs in
+          (app, strengthen_approx app approx_res)
+
+      | ((ufunct, (Value_closure(fundesc, _) as fapprox)), uargs)
+          when nargs < fundesc.fun_arity ->
+        let first_args = List.map (fun arg ->
+          (V.create_local "arg", arg) ) uargs in
+        let final_args =
+          Array.to_list (Array.init (fundesc.fun_arity - nargs)
+                                    (fun _ -> V.create_local "arg")) in
+        let rec iter args body =
+          match args with
+              [] -> body
+            | (arg1, arg2) :: args ->
+              iter args
+                (Ulet (Immutable, Pgenval, VP.create arg1, arg2, body))
+        in
+        let internal_args =
+          (List.map (fun (arg1, _arg2) -> Lvar arg1) first_args)
+          @ (List.map (fun arg -> Lvar arg ) final_args)
+        in
+        let funct_var = V.create_local "funct" in
+        let fenv = V.Map.add funct_var fapprox fenv in
+        let (new_fun, approx) = close { backend; fenv; cenv }
+          (Lfunction{
+               kind = Curried;
+               return = Pgenval;
+               params = List.map (fun v -> v, Pgenval) final_args;
+               body = Lapply{ap_should_be_tailcall=false;
+                             ap_loc=loc;
+                             ap_func=(Lvar funct_var);
+                             ap_args=internal_args;
+                             ap_inlined=Default_inline;
+                             ap_specialised=Default_specialise};
+               loc;
+               attr = default_function_attribute})
+        in
+        let new_fun =
+          iter first_args
+            (Ulet (Immutable, Pgenval, VP.create funct_var, ufunct, new_fun))
+        in
+        warning_if_forced_inline ~loc ~attribute "Partial application";
+        (new_fun, approx)
+
+      | ((ufunct, Value_closure(fundesc, _approx_res)), uargs)
+        when fundesc.fun_arity > 0 && nargs > fundesc.fun_arity ->
+          let args = List.map (fun arg -> V.create_local "arg", arg) uargs in
+          let (first_args, rem_args) = split_list fundesc.fun_arity args in
+          let first_args = List.map (fun (id, _) -> Uvar id) first_args in
+          let rem_args = List.map (fun (id, _) -> Uvar id) rem_args in
+          let dbg = Debuginfo.from_location loc in
+          warning_if_forced_inline ~loc ~attribute "Over-application";
+          let body =
+            Ugeneric_apply(direct_apply ~backend ~loc ~attribute
+                              fundesc ufunct first_args,
+                           rem_args, dbg)
+          in
+          let result =
+            List.fold_left (fun body (id, defining_expr) ->
+                Ulet (Immutable, Pgenval, VP.create id, defining_expr, body))
+              body
+              args
+          in
+          result, Value_unknown
+      | ((ufunct, _), uargs) ->
+          let dbg = Debuginfo.from_location loc in
+          warning_if_forced_inline ~loc ~attribute "Unknown function";
+          (Ugeneric_apply(ufunct, uargs, dbg), Value_unknown)
+      end
+  | Lsend(kind, met, obj, args, loc) ->
+      let (umet, _) = close env met in
+      let (uobj, _) = close env obj in
+      let dbg = Debuginfo.from_location loc in
+      (Usend(kind, umet, uobj, close_list env args, dbg),
+       Value_unknown)
+  | Llet(str, kind, id, lam, body) ->
+      let (ulam, alam) = close_named env id lam in
+      begin match (str, alam) with
+        (Variable, _) ->
+          let (ubody, abody) = close env body in
+          (Ulet(Mutable, kind, VP.create id, ulam, ubody), abody)
+      | (_, Value_const _)
+        when str = Alias || is_pure ulam ->
+          close { backend; fenv = (V.Map.add id alam fenv); cenv } body
+      | (_, _) ->
+          let (ubody, abody) =
+            close { backend; fenv = (V.Map.add id alam fenv); cenv } body
+          in
+          (Ulet(Immutable, kind, VP.create id, ulam, ubody), abody)
+      end
+  | Lletrec(defs, body) ->
+      if List.for_all
+           (function (_id, Lfunction _) -> true | _ -> false)
+           defs
+      then begin
+        (* Simple case: only function definitions *)
+        let (clos, infos) = close_functions env defs in
+        let clos_ident = V.create_local "clos" in
+        let fenv_body =
+          List.fold_right
+            (fun (id, _pos, approx) fenv -> V.Map.add id approx fenv)
+            infos fenv in
+        let (ubody, approx) = close { backend; fenv = fenv_body; cenv } body in
+        let sb =
+          List.fold_right
+            (fun (id, pos, _approx) sb ->
+              V.Map.add id (Uoffset(Uvar clos_ident, pos)) sb)
+            infos V.Map.empty in
+        (Ulet(Immutable, Pgenval, VP.create clos_ident, clos,
+              substitute Location.none (backend, !Clflags.float_const_prop) sb
+                None ubody),
+         approx)
+      end else begin
+        (* General case: recursive definition of values *)
+        let rec clos_defs = function
+          [] -> ([], fenv)
+        | (id, lam) :: rem ->
+            let (udefs, fenv_body) = clos_defs rem in
+            let (ulam, approx) = close_named env id lam in
+            ((VP.create id, ulam) :: udefs, V.Map.add id approx fenv_body) in
+        let (udefs, fenv_body) = clos_defs defs in
+        let (ubody, approx) = close { backend; fenv = fenv_body; cenv } body in
+        (Uletrec(udefs, ubody), approx)
+      end
+  (* Compile-time constants *)
+  | Lprim(Pctconst c, [arg], _loc) ->
+      let cst, approx =
+        match c with
+        | Big_endian -> make_const_bool B.big_endian
+        | Word_size -> make_const_int (8*B.size_int)
+        | Int_size -> make_const_int (8*B.size_int - 1)
+        | Max_wosize -> make_const_int ((1 lsl ((8*B.size_int) - 10)) - 1 )
+        | Ostype_unix -> make_const_bool (Sys.os_type = "Unix")
+        | Ostype_win32 -> make_const_bool (Sys.os_type = "Win32")
+        | Ostype_cygwin -> make_const_bool (Sys.os_type = "Cygwin")
+        | Backend_type ->
+            make_const_ptr 0 (* tag 0 is the same as Native here *)
+      in
+      let arg, _approx = close env arg in
+      let id = Ident.create_local "dummy" in
+      Ulet(Immutable, Pgenval, VP.create id, arg, cst), approx
+  | Lprim(Pignore, [arg], _loc) ->
+      let expr, approx = make_const_ptr 0 in
+      Usequence(fst (close env arg), expr), approx
+  | Lprim((Pidentity | Pbytes_to_string | Pbytes_of_string), [arg], _loc) ->
+      close env arg
+  | Lprim(Pdirapply,[funct;arg], loc)
+  | Lprim(Prevapply,[arg;funct], loc) ->
+      close env       (Lapply{ap_should_be_tailcall=false;
+                              ap_loc=loc;
+                              ap_func=funct;
+                              ap_args=[arg];
+                              ap_inlined=Default_inline;
+                              ap_specialised=Default_specialise})
+  | Lprim(Pgetglobal id, [], loc) ->
+      let dbg = Debuginfo.from_location loc in
+      check_constant_result (getglobal dbg id)
+                            (Compilenv.global_approx id)
+  | Lprim(Pfield n, [lam], loc) ->
+      let (ulam, approx) = close env lam in
+      let dbg = Debuginfo.from_location loc in
+      check_constant_result (Uprim(P.Pfield n, [ulam], dbg))
+                            (field_approx n approx)
+  | Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, [], _); lam], loc)->
+      let (ulam, approx) = close env lam in
+      if approx <> Value_unknown then
+        (!global_approx).(n) <- approx;
+      let dbg = Debuginfo.from_location loc in
+      (Uprim(P.Psetfield(n, is_ptr, init), [getglobal dbg id; ulam], dbg),
+       Value_unknown)
+  | Lprim(Praise k, [arg], loc) ->
+      let (ulam, _approx) = close env arg in
+      let dbg = Debuginfo.from_location loc in
+      (Uprim(P.Praise k, [ulam], dbg),
+       Value_unknown)
+  | Lprim (Pmakearray _, [], _loc) -> make_const_ref (Uconst_block (0, []))
+  | Lprim(p, args, loc) ->
+      let p = Convert_primitives.convert p in
+      let dbg = Debuginfo.from_location loc in
+      simplif_prim ~backend !Clflags.float_const_prop
+                   p (close_list_approx env args) dbg
+  | Lswitch(arg, sw, dbg) ->
+      let fn fail =
+        let (uarg, _) = close env arg in
+        let const_index, const_actions, fconst =
+          close_switch env sw.sw_consts sw.sw_numconsts fail
+        and block_index, block_actions, fblock =
+          close_switch env sw.sw_blocks sw.sw_numblocks fail in
+        let ulam =
+          Uswitch
+            (uarg,
+             {us_index_consts = const_index;
+              us_actions_consts = const_actions;
+              us_index_blocks = block_index;
+              us_actions_blocks = block_actions},
+             Debuginfo.from_location dbg)
+        in
+        (fconst (fblock ulam),Value_unknown) in
+(* NB: failaction might get copied, thus it should be some Lstaticraise *)
+      let fail = sw.sw_failaction in
+      begin match fail with
+      | None|Some (Lstaticraise (_,_)) -> fn fail
+      | Some lamfail ->
+          if
+            (sw.sw_numconsts - List.length sw.sw_consts) +
+            (sw.sw_numblocks - List.length sw.sw_blocks) > 1
+          then
+            let i = next_raise_count () in
+            let ubody,_ = fn (Some (Lstaticraise (i,[])))
+            and uhandler,_ = close env lamfail in
+            Ucatch (i,[],ubody,uhandler),Value_unknown
+          else fn fail
+      end
+  | Lstringswitch(arg,sw,d,_) ->
+      let uarg,_ = close env arg in
+      let usw =
+        List.map
+          (fun (s,act) ->
+            let uact,_ = close env act in
+            s,uact)
+          sw in
+      let ud =
+        Misc.may_map
+          (fun d ->
+            let ud,_ = close env d in
+            ud) d in
+      Ustringswitch (uarg,usw,ud),Value_unknown
+  | Lstaticraise (i, args) ->
+      (Ustaticfail (i, close_list env args), Value_unknown)
+  | Lstaticcatch(body, (i, vars), handler) ->
+      let (ubody, _) = close env body in
+      let (uhandler, _) = close env handler in
+      let vars = List.map (fun (var, k) -> VP.create var, k) vars in
+      (Ucatch(i, vars, ubody, uhandler), Value_unknown)
+  | Ltrywith(body, id, handler) ->
+      let (ubody, _) = close env body in
+      let (uhandler, _) = close env handler in
+      (Utrywith(ubody, VP.create id, uhandler), Value_unknown)
+  | Lifthenelse(arg, ifso, ifnot) ->
+      begin match close env arg with
+        (uarg, Value_const (Uconst_ptr n)) ->
+          sequence_constant_expr uarg
+            (close env (if n = 0 then ifnot else ifso))
+      | (uarg, _ ) ->
+          let (uifso, _) = close env ifso in
+          let (uifnot, _) = close env ifnot in
+          (Uifthenelse(uarg, uifso, uifnot), Value_unknown)
+      end
+  | Lsequence(lam1, lam2) ->
+      let (ulam1, _) = close env lam1 in
+      let (ulam2, approx) = close env lam2 in
+      (Usequence(ulam1, ulam2), approx)
+  | Lwhile(cond, body) ->
+      let (ucond, _) = close env cond in
+      let (ubody, _) = close env body in
+      (Uwhile(ucond, ubody), Value_unknown)
+  | Lfor(id, lo, hi, dir, body) ->
+      let (ulo, _) = close env lo in
+      let (uhi, _) = close env hi in
+      let (ubody, _) = close env body in
+      (Ufor(VP.create id, ulo, uhi, dir, ubody), Value_unknown)
+  | Lassign(id, lam) ->
+      let (ulam, _) = close env lam in
+      (Uassign(id, ulam), Value_unknown)
+  | Levent(lam, _) ->
+      close env lam
+  | Lifused _ ->
+      assert false
+
+and close_list env = function
+    [] -> []
+  | lam :: rem ->
+      let (ulam, _) = close env lam in
+      ulam :: close_list env rem
+
+and close_list_approx env = function
+    [] -> ([], [])
+  | lam :: rem ->
+      let (ulam, approx) = close env lam in
+      let (ulams, approxs) = close_list_approx env rem in
+      (ulam :: ulams, approx :: approxs)
+
+and close_named env id = function
+    Lfunction _ as funct ->
+      close_one_function env id funct
+  | lam ->
+      close env lam
+
+(* Build a shared closure for a set of mutually recursive functions *)
+
+and close_functions { backend; fenv; cenv } fun_defs =
+  let fun_defs =
+    List.flatten
+      (List.map
+         (function
+           | (id, Lfunction{kind; params; return; body; attr; loc}) ->
+               Simplif.split_default_wrapper ~id ~kind ~params
+                 ~body ~attr ~loc ~return
+           | _ -> assert false
+         )
+         fun_defs)
+  in
+  let inline_attribute = match fun_defs with
+    | [_, Lfunction{attr = { inline; }}] -> inline
+    | _ -> Default_inline (* recursive functions can't be inlined *)
+  in
+  (* Update and check nesting depth *)
+  incr function_nesting_depth;
+  let initially_closed =
+    !function_nesting_depth < excessive_function_nesting_depth in
+  (* Determine the free variables of the functions *)
+  let fv =
+    V.Set.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in
+  (* Build the function descriptors for the functions.
+     Initially all functions are assumed not to need their environment
+     parameter. *)
+  let uncurried_defs =
+    List.map
+      (function
+          (id, Lfunction{kind; params; return; body; loc}) ->
+            let label = Compilenv.make_symbol (Some (V.unique_name id)) in
+            let arity = List.length params in
+            let fundesc =
+              {fun_label = label;
+               fun_arity = (if kind = Tupled then -arity else arity);
+               fun_closed = initially_closed;
+               fun_inline = None;
+               fun_float_const_prop = !Clflags.float_const_prop } in
+            let dbg = Debuginfo.from_location loc in
+            (id, params, return, body, fundesc, dbg)
+        | (_, _) -> fatal_error "Closure.close_functions")
+      fun_defs in
+  (* Build an approximate fenv for compiling the functions *)
+  let fenv_rec =
+    List.fold_right
+      (fun (id, _params, _return, _body, fundesc, _dbg) fenv ->
+        V.Map.add id (Value_closure(fundesc, Value_unknown)) fenv)
+      uncurried_defs fenv in
+  (* Determine the offsets of each function's closure in the shared block *)
+  let env_pos = ref (-1) in
+  let clos_offsets =
+    List.map
+      (fun (_id, _params, _return, _body, fundesc, _dbg) ->
+        let pos = !env_pos + 1 in
+        env_pos := !env_pos + 1 + (if fundesc.fun_arity <> 1 then 3 else 2);
+        pos)
+      uncurried_defs in
+  let fv_pos = !env_pos in
+  (* This reference will be set to false if the hypothesis that a function
+     does not use its environment parameter is invalidated. *)
+  let useless_env = ref initially_closed in
+  (* Translate each function definition *)
+  let clos_fundef (id, params, return, body, fundesc, dbg) env_pos =
+    let env_param = V.create_local "env" in
+    let cenv_fv =
+      build_closure_env env_param (fv_pos - env_pos) fv in
+    let cenv_body =
+      List.fold_right2
+        (fun (id, _params, _return, _body, _fundesc, _dbg) pos env ->
+          V.Map.add id (Uoffset(Uvar env_param, pos - env_pos)) env)
+        uncurried_defs clos_offsets cenv_fv in
+    let (ubody, approx) =
+      close { backend; fenv = fenv_rec; cenv = cenv_body } body
+    in
+    if !useless_env && occurs_var env_param ubody then raise NotClosed;
+    let fun_params =
+      if !useless_env
+      then params
+      else params @ [env_param, Pgenval]
+    in
+    let f =
+      {
+        label  = fundesc.fun_label;
+        arity  = fundesc.fun_arity;
+        params = List.map (fun (var, kind) -> VP.create var, kind) fun_params;
+        return;
+        body   = ubody;
+        dbg;
+        env = Some env_param;
+      }
+    in
+    (* give more chance of function with default parameters (i.e.
+       their wrapper functions) to be inlined *)
+    let n =
+      List.fold_left
+        (fun n (id, _) -> n + if V.name id = "*opt*" then 8 else 1)
+        0
+        fun_params
+    in
+    let threshold =
+      match inline_attribute with
+      | Default_inline ->
+          let inline_threshold =
+            Clflags.Float_arg_helper.get ~key:0 !Clflags.inline_threshold
+          in
+          let magic_scale_constant = 8. in
+          int_of_float (inline_threshold *. magic_scale_constant) + n
+      | Always_inline -> max_int
+      | Never_inline -> min_int
+      | Unroll _ -> assert false
+    in
+    let fun_params = List.map (fun (var, _) -> VP.create var) fun_params in
+    if lambda_smaller ubody threshold
+    then fundesc.fun_inline <- Some(fun_params, ubody);
+
+    (f, (id, env_pos, Value_closure(fundesc, approx))) in
+  (* Translate all function definitions. *)
+  let clos_info_list =
+    if initially_closed then begin
+      let snap = Compilenv.snapshot () in
+      try List.map2 clos_fundef uncurried_defs clos_offsets
+      with NotClosed ->
+      (* If the hypothesis that the environment parameters are useless has been
+         invalidated, then set [fun_closed] to false in all descriptions and
+         recompile *)
+        Compilenv.backtrack snap; (* PR#6337 *)
+        List.iter
+          (fun (_id, _params, _return, _body, fundesc, _dbg) ->
+             fundesc.fun_closed <- false;
+             fundesc.fun_inline <- None;
+          )
+          uncurried_defs;
+        useless_env := false;
+        List.map2 clos_fundef uncurried_defs clos_offsets
+    end else
+      (* Excessive closure nesting: assume environment parameter is used *)
+        List.map2 clos_fundef uncurried_defs clos_offsets
+    in
+  (* Update nesting depth *)
+  decr function_nesting_depth;
+  (* Return the Uclosure node and the list of all identifiers defined,
+     with offsets and approximations. *)
+  let (clos, infos) = List.split clos_info_list in
+  let fv = if !useless_env then [] else fv in
+  (Uclosure(clos, List.map (close_var { backend; fenv; cenv }) fv), infos)
+
+(* Same, for one non-recursive function *)
+
+and close_one_function env id funct =
+  match close_functions env [id, funct] with
+  | (clos, (i, _, approx) :: _) when id = i -> (clos, approx)
+  | _ -> fatal_error "Closure.close_one_function"
+
+(* Close a switch *)
+
+and close_switch env cases num_keys default =
+  let ncases = List.length cases in
+  let index = Array.make num_keys 0
+  and store = Storer.mk_store () in
+
+  (* First default case *)
+  begin match default with
+  | Some def when ncases < num_keys ->
+      assert (store.act_store () def = 0)
+  | _ -> ()
+  end ;
+  (* Then all other cases *)
+  List.iter
+    (fun (key,lam) ->
+     index.(key) <- store.act_store () lam)
+    cases ;
+
+  (*  Explicit sharing with catch/exit, as switcher compilation may
+      later unshare *)
+  let acts = store.act_get_shared () in
+  let hs = ref (fun e -> e) in
+
+  (* Compile actions *)
+  let actions =
+    Array.map
+      (function
+        | Single lam|Shared (Lstaticraise (_,[]) as lam) ->
+            let ulam,_ = close env lam in
+            ulam
+        | Shared lam ->
+            let ulam,_ = close env lam in
+            let i = next_raise_count () in
+(*
+            let string_of_lambda e =
+              Printlambda.lambda Format.str_formatter e ;
+              Format.flush_str_formatter () in
+            Printf.eprintf "SHARE CLOSURE %i [%s]\n%s\n" i
+                (string_of_lambda arg)
+                (string_of_lambda lam) ;
+*)
+            let ohs = !hs in
+            hs := (fun e -> Ucatch (i,[],ohs e,ulam)) ;
+            Ustaticfail (i,[]))
+      acts in
+  match actions with
+  | [| |] -> [| |], [| |], !hs (* May happen when default is None *)
+  | _     -> index, actions, !hs
+
+
+(* Collect exported symbols for structured constants *)
+
+let collect_exported_structured_constants a =
+  let rec approx = function
+    | Value_closure (fd, a) ->
+        approx a;
+        begin match fd.fun_inline with
+        | Some (_, u) -> ulam u
+        | None -> ()
+        end
+    | Value_tuple a -> Array.iter approx a
+    | Value_const c -> const c
+    | Value_unknown | Value_global_field _ -> ()
+  and const = function
+    | Uconst_ref (s, (Some c)) ->
+        Compilenv.add_exported_constant s;
+        structured_constant c
+    | Uconst_ref (_s, None) -> assert false (* Cannot be generated *)
+    | Uconst_int _ | Uconst_ptr _ -> ()
+  and structured_constant = function
+    | Uconst_block (_, ul) -> List.iter const ul
+    | Uconst_float _ | Uconst_int32 _
+    | Uconst_int64 _ | Uconst_nativeint _
+    | Uconst_float_array _ | Uconst_string _ -> ()
+    | Uconst_closure _ -> assert false (* Cannot be generated *)
+  and ulam = function
+    | Uvar _ -> ()
+    | Uconst c -> const c
+    | Udirect_apply (_, ul, _) -> List.iter ulam ul
+    | Ugeneric_apply (u, ul, _) -> ulam u; List.iter ulam ul
+    | Uclosure (fl, ul) ->
+        List.iter (fun f -> ulam f.body) fl;
+        List.iter ulam ul
+    | Uoffset(u, _) -> ulam u
+    | Ulet (_str, _kind, _, u1, u2) -> ulam u1; ulam u2
+    | Uphantom_let _ -> no_phantom_lets ()
+    | Uletrec (l, u) -> List.iter (fun (_, u) -> ulam u) l; ulam u
+    | Uprim (_, ul, _) -> List.iter ulam ul
+    | Uswitch (u, sl, _dbg) ->
+        ulam u;
+        Array.iter ulam sl.us_actions_consts;
+        Array.iter ulam sl.us_actions_blocks
+    | Ustringswitch (u,sw,d) ->
+        ulam u ;
+        List.iter (fun (_,act) -> ulam act) sw ;
+        Misc.may ulam d
+    | Ustaticfail (_, ul) -> List.iter ulam ul
+    | Ucatch (_, _, u1, u2)
+    | Utrywith (u1, _, u2)
+    | Usequence (u1, u2)
+    | Uwhile (u1, u2)  -> ulam u1; ulam u2
+    | Uifthenelse (u1, u2, u3)
+    | Ufor (_, u1, u2, _, u3) -> ulam u1; ulam u2; ulam u3
+    | Uassign (_, u) -> ulam u
+    | Usend (_, u1, u2, ul, _) -> ulam u1; ulam u2; List.iter ulam ul
+    | Uunreachable -> ()
+  in
+  approx a
+
+let reset () =
+  global_approx := [||];
+  function_nesting_depth := 0
+
+(* The entry point *)
+
+let intro ~backend ~size lam =
+  reset ();
+  let id = Compilenv.make_symbol None in
+  global_approx := Array.init size (fun i -> Value_global_field (id, i));
+  Compilenv.set_global_approx(Value_tuple !global_approx);
+  let (ulam, _approx) =
+    close { backend; fenv = V.Map.empty; cenv = V.Map.empty } lam
+  in
+  let opaque =
+    !Clflags.opaque
+    || Env.is_imported_opaque (Compilenv.current_unit_name ())
+  in
+  if opaque
+  then Compilenv.set_global_approx(Value_unknown)
+  else collect_exported_structured_constants (Value_tuple !global_approx);
+  global_approx := [||];
+  ulam
diff --git a/middle_end/closure/closure.mli b/middle_end/closure/closure.mli
new file mode 100644
index 0000000000..92c74732b2
--- /dev/null
+++ b/middle_end/closure/closure.mli
@@ -0,0 +1,24 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Introduction of closures, uncurrying, recognition of direct calls *)
+
+val intro
+   : backend:(module Backend_intf.S)
+  -> size:int
+  -> Lambda.lambda
+  -> Clambda.ulambda
+
+val reset : unit -> unit
diff --git a/middle_end/base_types/compilation_unit.ml b/middle_end/compilation_unit.ml
index 7fb48167bc..7fb48167bc 100644
--- a/middle_end/base_types/compilation_unit.ml
+++ b/middle_end/compilation_unit.ml
diff --git a/middle_end/base_types/compilation_unit.mli b/middle_end/compilation_unit.mli
index fc7d3bfded..fc7d3bfded 100644
--- a/middle_end/base_types/compilation_unit.mli
+++ b/middle_end/compilation_unit.mli
diff --git a/middle_end/compilenv.ml b/middle_end/compilenv.ml
new file mode 100644
index 0000000000..add4e90e57
--- /dev/null
+++ b/middle_end/compilenv.ml
@@ -0,0 +1,452 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2010 Institut National de Recherche en Informatique et     *)
+(*     en Automatique                                                     *)
+(*   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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compilation environments for compilation units *)
+
+[@@@ocaml.warning "+a-4-9-40-41-42"]
+
+open Config
+open Cmx_format
+
+type error =
+    Not_a_unit_info of string
+  | Corrupted_unit_info of string
+  | Illegal_renaming of string * string * string
+
+exception Error of error
+
+let global_infos_table =
+  (Hashtbl.create 17 : (string, unit_infos option) Hashtbl.t)
+let export_infos_table =
+  (Hashtbl.create 10 : (string, Export_info.t) Hashtbl.t)
+
+let imported_sets_of_closures_table =
+  (Set_of_closures_id.Tbl.create 10
+   : Simple_value_approx.function_declarations option
+       Set_of_closures_id.Tbl.t)
+
+module CstMap =
+  Map.Make(struct
+    type t = Clambda.ustructured_constant
+    let compare = Clambda.compare_structured_constants
+    (* PR#6442: it is incorrect to use Stdlib.compare on values of type t
+       because it compares "0.0" and "-0.0" equal. *)
+  end)
+
+type structured_constants =
+  {
+    strcst_shared: string CstMap.t;
+    strcst_all: (string * Clambda.ustructured_constant) list;
+  }
+
+let structured_constants_empty  =
+  {
+    strcst_shared = CstMap.empty;
+    strcst_all = [];
+  }
+
+let structured_constants = ref structured_constants_empty
+
+
+let exported_constants = Hashtbl.create 17
+
+let merged_environment = ref Export_info.empty
+
+let default_ui_export_info =
+  if Config.flambda then
+    Cmx_format.Flambda Export_info.empty
+  else
+    Cmx_format.Clambda Value_unknown
+
+let current_unit =
+  { ui_name = "";
+    ui_symbol = "";
+    ui_defines = [];
+    ui_imports_cmi = [];
+    ui_imports_cmx = [];
+    ui_curry_fun = [];
+    ui_apply_fun = [];
+    ui_send_fun = [];
+    ui_force_link = false;
+    ui_export_info = default_ui_export_info }
+
+let symbolname_for_pack pack name =
+  match pack with
+  | None -> name
+  | Some p ->
+      let b = Buffer.create 64 in
+      for i = 0 to String.length p - 1 do
+        match p.[i] with
+        | '.' -> Buffer.add_string b "__"
+        |  c  -> Buffer.add_char b c
+      done;
+      Buffer.add_string b "__";
+      Buffer.add_string b name;
+      Buffer.contents b
+
+let unit_id_from_name name = Ident.create_persistent name
+
+let concat_symbol unitname id =
+  unitname ^ "__" ^ id
+
+let make_symbol ?(unitname = current_unit.ui_symbol) idopt =
+  let prefix = "caml" ^ unitname in
+  match idopt with
+  | None -> prefix
+  | Some id -> concat_symbol prefix id
+
+let current_unit_linkage_name () =
+  Linkage_name.create (make_symbol ~unitname:current_unit.ui_symbol None)
+
+let reset ?packname name =
+  Hashtbl.clear global_infos_table;
+  Set_of_closures_id.Tbl.clear imported_sets_of_closures_table;
+  let symbol = symbolname_for_pack packname name in
+  current_unit.ui_name <- name;
+  current_unit.ui_symbol <- symbol;
+  current_unit.ui_defines <- [symbol];
+  current_unit.ui_imports_cmi <- [];
+  current_unit.ui_imports_cmx <- [];
+  current_unit.ui_curry_fun <- [];
+  current_unit.ui_apply_fun <- [];
+  current_unit.ui_send_fun <- [];
+  current_unit.ui_force_link <- !Clflags.link_everything;
+  Hashtbl.clear exported_constants;
+  structured_constants := structured_constants_empty;
+  current_unit.ui_export_info <- default_ui_export_info;
+  merged_environment := Export_info.empty;
+  Hashtbl.clear export_infos_table;
+  let compilation_unit =
+    Compilation_unit.create
+      (Ident.create_persistent name)
+      (current_unit_linkage_name ())
+  in
+  Compilation_unit.set_current compilation_unit
+
+let current_unit_infos () =
+  current_unit
+
+let current_unit_name () =
+  current_unit.ui_name
+
+let symbol_in_current_unit name =
+  let prefix = "caml" ^ current_unit.ui_symbol in
+  name = prefix ||
+  (let lp = String.length prefix in
+   String.length name >= 2 + lp
+   && String.sub name 0 lp = prefix
+   && name.[lp] = '_'
+   && name.[lp + 1] = '_')
+
+let read_unit_info filename =
+  let ic = open_in_bin filename in
+  try
+    let buffer = really_input_string ic (String.length cmx_magic_number) in
+    if buffer <> cmx_magic_number then begin
+      close_in ic;
+      raise(Error(Not_a_unit_info filename))
+    end;
+    let ui = (input_value ic : unit_infos) in
+    let crc = Digest.input ic in
+    close_in ic;
+    (ui, crc)
+  with End_of_file | Failure _ ->
+    close_in ic;
+    raise(Error(Corrupted_unit_info(filename)))
+
+let read_library_info filename =
+  let ic = open_in_bin filename in
+  let buffer = really_input_string ic (String.length cmxa_magic_number) in
+  if buffer <> cmxa_magic_number then
+    raise(Error(Not_a_unit_info filename));
+  let infos = (input_value ic : library_infos) in
+  close_in ic;
+  infos
+
+
+(* Read and cache info on global identifiers *)
+
+let get_global_info global_ident = (
+  let modname = Ident.name global_ident in
+  if modname = current_unit.ui_name then
+    Some current_unit
+  else begin
+    try
+      Hashtbl.find global_infos_table modname
+    with Not_found ->
+      let (infos, crc) =
+        if Env.is_imported_opaque modname then (None, None)
+        else begin
+          try
+            let filename =
+              Load_path.find_uncap (modname ^ ".cmx") in
+            let (ui, crc) = read_unit_info filename in
+            if ui.ui_name <> modname then
+              raise(Error(Illegal_renaming(modname, ui.ui_name, filename)));
+            (Some ui, Some crc)
+          with Not_found ->
+            let warn = Warnings.No_cmx_file modname in
+              Location.prerr_warning Location.none warn;
+              (None, None)
+          end
+      in
+      current_unit.ui_imports_cmx <-
+        (modname, crc) :: current_unit.ui_imports_cmx;
+      Hashtbl.add global_infos_table modname infos;
+      infos
+  end
+)
+
+let cache_unit_info ui =
+  Hashtbl.add global_infos_table ui.ui_name (Some ui)
+
+(* Return the approximation of a global identifier *)
+
+let get_clambda_approx ui =
+  assert(not Config.flambda);
+  match ui.ui_export_info with
+  | Flambda _ -> assert false
+  | Clambda approx -> approx
+
+let toplevel_approx :
+  (string, Clambda.value_approximation) Hashtbl.t = Hashtbl.create 16
+
+let record_global_approx_toplevel () =
+  Hashtbl.add toplevel_approx current_unit.ui_name
+    (get_clambda_approx current_unit)
+
+let global_approx id =
+  if Ident.is_predef id then Clambda.Value_unknown
+  else try Hashtbl.find toplevel_approx (Ident.name id)
+  with Not_found ->
+    match get_global_info id with
+      | None -> Clambda.Value_unknown
+      | Some ui -> get_clambda_approx ui
+
+(* Return the symbol used to refer to a global identifier *)
+
+let symbol_for_global id =
+  if Ident.is_predef id then
+    "caml_exn_" ^ Ident.name id
+  else begin
+    let unitname = Ident.name id in
+    match
+      try ignore (Hashtbl.find toplevel_approx unitname); None
+      with Not_found -> get_global_info id
+    with
+    | None -> make_symbol ~unitname:(Ident.name id) None
+    | Some ui -> make_symbol ~unitname:ui.ui_symbol None
+  end
+
+(* Register the approximation of the module being compiled *)
+
+let unit_for_global id =
+  let sym_label = Linkage_name.create (symbol_for_global id) in
+  Compilation_unit.create id sym_label
+
+let predefined_exception_compilation_unit =
+  Compilation_unit.create (Ident.create_persistent "__dummy__")
+    (Linkage_name.create "__dummy__")
+
+let is_predefined_exception sym =
+  Compilation_unit.equal
+    predefined_exception_compilation_unit
+    (Symbol.compilation_unit sym)
+
+let symbol_for_global' id =
+  let sym_label = Linkage_name.create (symbol_for_global id) in
+  if Ident.is_predef id then
+    Symbol.of_global_linkage predefined_exception_compilation_unit sym_label
+  else
+    Symbol.of_global_linkage (unit_for_global id) sym_label
+
+let set_global_approx approx =
+  assert(not Config.flambda);
+  current_unit.ui_export_info <- Clambda approx
+
+(* Exporting and importing cross module information *)
+
+let get_flambda_export_info ui =
+  assert(Config.flambda);
+  match ui.ui_export_info with
+  | Clambda _ -> assert false
+  | Flambda ei -> ei
+
+let set_export_info export_info =
+  assert(Config.flambda);
+  current_unit.ui_export_info <- Flambda export_info
+
+let approx_for_global comp_unit =
+  let id = Compilation_unit.get_persistent_ident comp_unit in
+  if (Compilation_unit.equal
+      predefined_exception_compilation_unit
+      comp_unit)
+     || Ident.is_predef id
+     || not (Ident.global id)
+  then invalid_arg (Format.asprintf "approx_for_global %a" Ident.print id);
+  let modname = Ident.name id in
+  match Hashtbl.find export_infos_table modname with
+  | otherwise -> Some otherwise
+  | exception Not_found ->
+    match get_global_info id with
+    | None -> None
+    | Some ui ->
+      let exported = get_flambda_export_info ui in
+      Hashtbl.add export_infos_table modname exported;
+      merged_environment := Export_info.merge !merged_environment exported;
+      Some exported
+
+let approx_env () = !merged_environment
+
+(* Record that a currying function or application function is needed *)
+
+let need_curry_fun n =
+  if not (List.mem n current_unit.ui_curry_fun) then
+    current_unit.ui_curry_fun <- n :: current_unit.ui_curry_fun
+
+let need_apply_fun n =
+  assert(n > 0);
+  if not (List.mem n current_unit.ui_apply_fun) then
+    current_unit.ui_apply_fun <- n :: current_unit.ui_apply_fun
+
+let need_send_fun n =
+  if not (List.mem n current_unit.ui_send_fun) then
+    current_unit.ui_send_fun <- n :: current_unit.ui_send_fun
+
+(* Write the description of the current unit *)
+
+let write_unit_info info filename =
+  let oc = open_out_bin filename in
+  output_string oc cmx_magic_number;
+  output_value oc info;
+  flush oc;
+  let crc = Digest.file filename in
+  Digest.output oc crc;
+  close_out oc
+
+let save_unit_info filename =
+  current_unit.ui_imports_cmi <- Env.imports();
+  write_unit_info current_unit filename
+
+let current_unit () =
+  match Compilation_unit.get_current () with
+  | Some current_unit -> current_unit
+  | None -> Misc.fatal_error "Compilenv.current_unit"
+
+let current_unit_symbol () =
+  Symbol.of_global_linkage (current_unit ()) (current_unit_linkage_name ())
+
+let const_label = ref 0
+
+let new_const_symbol () =
+  incr const_label;
+  make_symbol (Some (Int.to_string !const_label))
+
+let snapshot () = !structured_constants
+let backtrack s = structured_constants := s
+
+let new_structured_constant cst ~shared =
+  let {strcst_shared; strcst_all} = !structured_constants in
+  if shared then
+    try
+      CstMap.find cst strcst_shared
+    with Not_found ->
+      let lbl = new_const_symbol() in
+      structured_constants :=
+        {
+          strcst_shared = CstMap.add cst lbl strcst_shared;
+          strcst_all = (lbl, cst) :: strcst_all;
+        };
+      lbl
+  else
+    let lbl = new_const_symbol() in
+    structured_constants :=
+      {
+        strcst_shared;
+        strcst_all = (lbl, cst) :: strcst_all;
+      };
+    lbl
+
+let add_exported_constant s =
+  Hashtbl.replace exported_constants s ()
+
+let clear_structured_constants () =
+  structured_constants := structured_constants_empty
+
+let structured_constants () =
+  let provenance : Clambda.usymbol_provenance =
+    { original_idents = [];
+      module_path =
+        Path.Pident (Ident.create_persistent (current_unit_name ()));
+    }
+  in
+  List.map
+    (fun (symbol, definition) ->
+       {
+         Clambda.symbol;
+         exported = Hashtbl.mem exported_constants symbol;
+         definition;
+         provenance = Some provenance;
+       })
+    (!structured_constants).strcst_all
+
+let closure_symbol fv =
+  let compilation_unit = Closure_id.get_compilation_unit fv in
+  let unitname =
+    Linkage_name.to_string (Compilation_unit.get_linkage_name compilation_unit)
+  in
+  let linkage_name =
+    concat_symbol unitname ((Closure_id.unique_name fv) ^ "_closure")
+  in
+  Symbol.of_global_linkage compilation_unit (Linkage_name.create linkage_name)
+
+let function_label fv =
+  let compilation_unit = Closure_id.get_compilation_unit fv in
+  let unitname =
+    Linkage_name.to_string
+      (Compilation_unit.get_linkage_name compilation_unit)
+  in
+  (concat_symbol unitname (Closure_id.unique_name fv))
+
+let require_global global_ident =
+  if not (Ident.is_predef global_ident) then
+    ignore (get_global_info global_ident : Cmx_format.unit_infos option)
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+  | Not_a_unit_info filename ->
+      fprintf ppf "%a@ is not a compilation unit description."
+        Location.print_filename filename
+  | Corrupted_unit_info filename ->
+      fprintf ppf "Corrupted compilation unit description@ %a"
+        Location.print_filename filename
+  | Illegal_renaming(name, modname, filename) ->
+      fprintf ppf "%a@ contains the description for unit\
+                   @ %s when %s was expected"
+        Location.print_filename filename name modname
+
+let () =
+  Location.register_error_of_exn
+    (function
+      | Error err -> Some (Location.error_of_printer_file report_error err)
+      | _ -> None
+    )
diff --git a/middle_end/compilenv.mli b/middle_end/compilenv.mli
new file mode 100644
index 0000000000..569d51ea08
--- /dev/null
+++ b/middle_end/compilenv.mli
@@ -0,0 +1,153 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2010 Institut National de Recherche en Informatique et     *)
+(*     en Automatique                                                     *)
+(*   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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Compilation environments for compilation units *)
+
+open Cmx_format
+
+(* CR-soon mshinwell: this is a bit ugly
+   mshinwell: deferred CR, this has been addressed in the export info
+   improvement feature.
+*)
+val imported_sets_of_closures_table
+  : Simple_value_approx.function_declarations option Set_of_closures_id.Tbl.t
+        (* flambda-only *)
+
+val reset: ?packname:string -> string -> unit
+        (* Reset the environment and record the name of the unit being
+           compiled (arg).  Optional argument is [-for-pack] prefix. *)
+
+val unit_id_from_name: string -> Ident.t
+        (* flambda-only *)
+
+val current_unit_infos: unit -> unit_infos
+        (* Return the infos for the unit being compiled *)
+
+val current_unit_name: unit -> string
+        (* Return the name of the unit being compiled
+           clambda-only *)
+
+val current_unit_linkage_name: unit -> Linkage_name.t
+        (* Return the linkage_name of the unit being compiled.
+           flambda-only *)
+
+val current_unit: unit -> Compilation_unit.t
+        (* flambda-only *)
+
+val current_unit_symbol: unit -> Symbol.t
+        (* flambda-only *)
+
+val make_symbol: ?unitname:string -> string option -> string
+        (* [make_symbol ~unitname:u None] returns the asm symbol that
+           corresponds to the compilation unit [u] (default: the current unit).
+           [make_symbol ~unitname:u (Some id)] returns the asm symbol that
+           corresponds to symbol [id] in the compilation unit [u]
+           (or the current unit). *)
+
+val symbol_in_current_unit: string -> bool
+        (* Return true if the given asm symbol belongs to the
+           current compilation unit, false otherwise. *)
+
+val is_predefined_exception: Symbol.t -> bool
+        (* flambda-only *)
+
+val unit_for_global: Ident.t -> Compilation_unit.t
+        (* flambda-only *)
+
+val symbol_for_global: Ident.t -> string
+        (* Return the asm symbol that refers to the given global identifier
+           flambda-only *)
+val symbol_for_global': Ident.t -> Symbol.t
+        (* flambda-only *)
+val global_approx: Ident.t -> Clambda.value_approximation
+        (* Return the approximation for the given global identifier
+           clambda-only *)
+val set_global_approx: Clambda.value_approximation -> unit
+        (* Record the approximation of the unit being compiled
+           clambda-only *)
+val record_global_approx_toplevel: unit -> unit
+        (* Record the current approximation for the current toplevel phrase
+           clambda-only *)
+
+val set_export_info: Export_info.t -> unit
+        (* Record the information of the unit being compiled
+           flambda-only *)
+val approx_env: unit -> Export_info.t
+        (* Returns all the information loaded from external compilation units
+           flambda-only *)
+val approx_for_global: Compilation_unit.t -> Export_info.t option
+        (* Loads the exported information declaring the compilation_unit
+           flambda-only *)
+
+val need_curry_fun: int -> unit
+val need_apply_fun: int -> unit
+val need_send_fun: int -> unit
+        (* Record the need of a currying (resp. application,
+           message sending) function with the given arity *)
+
+val new_const_symbol : unit -> string
+val closure_symbol : Closure_id.t -> Symbol.t
+        (* Symbol of a function if the function is
+           closed (statically allocated)
+           flambda-only *)
+val function_label : Closure_id.t -> string
+        (* linkage name of the code of a function
+           flambda-only *)
+
+val new_structured_constant:
+  Clambda.ustructured_constant ->
+  shared:bool -> (* can be shared with another structurally equal constant *)
+  string
+val structured_constants:
+  unit -> Clambda.preallocated_constant list
+val clear_structured_constants: unit -> unit
+val add_exported_constant: string -> unit
+        (* clambda-only *)
+type structured_constants
+        (* clambda-only *)
+val snapshot: unit -> structured_constants
+        (* clambda-only *)
+val backtrack: structured_constants -> unit
+        (* clambda-only *)
+
+val read_unit_info: string -> unit_infos * Digest.t
+        (* Read infos and MD5 from a [.cmx] file. *)
+val write_unit_info: unit_infos -> string -> unit
+        (* Save the given infos in the given file *)
+val save_unit_info: string -> unit
+        (* Save the infos for the current unit in the given file *)
+val cache_unit_info: unit_infos -> unit
+        (* Enter the given infos in the cache.  The infos will be
+           honored by [symbol_for_global] and [global_approx]
+           without looking at the corresponding .cmx file. *)
+
+val require_global: Ident.t -> unit
+        (* Enforce a link dependency of the current compilation
+           unit to the required module *)
+
+val read_library_info: string -> library_infos
+
+type error =
+    Not_a_unit_info of string
+  | Corrupted_unit_info of string
+  | Illegal_renaming of string * string * string
+
+exception Error of error
+
+val report_error: Format.formatter -> error -> unit
diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml
new file mode 100644
index 0000000000..17d17ea8af
--- /dev/null
+++ b/middle_end/convert_primitives.ml
@@ -0,0 +1,153 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2017 OCamlPro SAS                                          *)
+(*   Copyright 2017 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+let convert_unsafety is_unsafe : Clambda_primitives.is_safe =
+  if is_unsafe then
+    Unsafe
+  else
+    Safe
+
+let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
+  match prim with
+  | Pmakeblock (tag, mutability, shape) ->
+      Pmakeblock (tag, mutability, shape)
+  | Pfield field -> Pfield field
+  | Pfield_computed -> Pfield_computed
+  | Psetfield (field, imm_or_pointer, init_or_assign) ->
+      Psetfield (field, imm_or_pointer, init_or_assign)
+  | Psetfield_computed (imm_or_pointer, init_or_assign) ->
+      Psetfield_computed (imm_or_pointer, init_or_assign)
+  | Pfloatfield field -> Pfloatfield field
+  | Psetfloatfield (field, init_or_assign) ->
+      Psetfloatfield (field, init_or_assign)
+  | Pduprecord (repr, size) -> Pduprecord (repr, size)
+  | Pccall prim -> Pccall prim
+  | Praise kind -> Praise kind
+  | Psequand -> Psequand
+  | Psequor -> Psequor
+  | Pnot -> Pnot
+  | Pnegint -> Pnegint
+  | Paddint -> Paddint
+  | Psubint -> Psubint
+  | Pmulint -> Pmulint
+  | Pdivint is_safe -> Pdivint is_safe
+  | Pmodint is_safe -> Pmodint is_safe
+  | Pandint -> Pandint
+  | Porint -> Porint
+  | Pxorint -> Pxorint
+  | Plslint -> Plslint
+  | Plsrint -> Plsrint
+  | Pasrint -> Pasrint
+  | Pintcomp comp -> Pintcomp comp
+  | Poffsetint offset -> Poffsetint offset
+  | Poffsetref offset -> Poffsetref offset
+  | Pintoffloat -> Pintoffloat
+  | Pfloatofint -> Pfloatofint
+  | Pnegfloat -> Pnegfloat
+  | Pabsfloat -> Pabsfloat
+  | Paddfloat -> Paddfloat
+  | Psubfloat -> Psubfloat
+  | Pmulfloat -> Pmulfloat
+  | Pdivfloat -> Pdivfloat
+  | Pfloatcomp comp -> Pfloatcomp comp
+  | Pstringlength -> Pstringlength
+  | Pstringrefu -> Pstringrefu
+  | Pstringrefs -> Pstringrefs
+  | Pbyteslength -> Pbyteslength
+  | Pbytesrefu -> Pbytesrefu
+  | Pbytessetu -> Pbytessetu
+  | Pbytesrefs -> Pbytesrefs
+  | Pbytessets -> Pbytessets
+  | Pmakearray (kind, mutability) -> Pmakearray (kind, mutability)
+  | Pduparray (kind, mutability) -> Pduparray (kind, mutability)
+  | Parraylength kind -> Parraylength kind
+  | Parrayrefu kind -> Parrayrefu kind
+  | Parraysetu kind -> Parraysetu kind
+  | Parrayrefs kind -> Parrayrefs kind
+  | Parraysets kind -> Parraysets kind
+  | Pisint -> Pisint
+  | Pisout -> Pisout
+  | Pcvtbint (src, dest) -> Pcvtbint (src, dest)
+  | Pnegbint bi -> Pnegbint bi
+  | Paddbint bi -> Paddbint bi
+  | Psubbint bi -> Psubbint bi
+  | Pmulbint bi -> Pmulbint bi
+  | Pbintofint bi -> Pbintofint bi
+  | Pintofbint bi -> Pintofbint bi
+  | Pandbint bi -> Pandbint bi
+  | Porbint bi -> Porbint bi
+  | Pxorbint bi -> Pxorbint bi
+  | Plslbint bi -> Plslbint bi
+  | Plsrbint bi -> Plsrbint bi
+  | Pasrbint bi -> Pasrbint bi
+  | Pbbswap bi -> Pbbswap bi
+  | Pdivbint { size; is_safe } -> Pdivbint { size; is_safe }
+  | Pmodbint { size; is_safe } -> Pmodbint { size; is_safe }
+  | Pbintcomp (bi, comp) -> Pbintcomp (bi, comp)
+  | Pbigarrayref (safe, dims, kind, layout) ->
+      Pbigarrayref (safe, dims, kind, layout)
+  | Pbigarrayset (safe, dims, kind, layout) ->
+      Pbigarrayset (safe, dims, kind, layout)
+  | Pstring_load_16 is_unsafe ->
+      Pstring_load (Sixteen, convert_unsafety is_unsafe)
+  | Pstring_load_32 is_unsafe ->
+      Pstring_load (Thirty_two, convert_unsafety is_unsafe)
+  | Pstring_load_64 is_unsafe ->
+      Pstring_load (Sixty_four, convert_unsafety is_unsafe)
+  | Pbytes_load_16 is_unsafe ->
+      Pbytes_load (Sixteen, convert_unsafety is_unsafe)
+  | Pbytes_load_32 is_unsafe ->
+      Pbytes_load (Thirty_two, convert_unsafety is_unsafe)
+  | Pbytes_load_64 is_unsafe ->
+      Pbytes_load (Sixty_four, convert_unsafety is_unsafe)
+  | Pbytes_set_16 is_unsafe ->
+      Pbytes_set (Sixteen, convert_unsafety is_unsafe)
+  | Pbytes_set_32 is_unsafe ->
+      Pbytes_set (Thirty_two, convert_unsafety is_unsafe)
+  | Pbytes_set_64 is_unsafe ->
+      Pbytes_set (Sixty_four, convert_unsafety is_unsafe)
+  | Pbigstring_load_16 is_unsafe ->
+      Pbigstring_load (Sixteen, convert_unsafety is_unsafe)
+  | Pbigstring_load_32 is_unsafe ->
+      Pbigstring_load (Thirty_two, convert_unsafety is_unsafe)
+  | Pbigstring_load_64 is_unsafe ->
+      Pbigstring_load (Sixty_four, convert_unsafety is_unsafe)
+  | Pbigstring_set_16 is_unsafe ->
+      Pbigstring_set (Sixteen, convert_unsafety is_unsafe)
+  | Pbigstring_set_32 is_unsafe ->
+      Pbigstring_set (Thirty_two, convert_unsafety is_unsafe)
+  | Pbigstring_set_64 is_unsafe ->
+      Pbigstring_set (Sixty_four, convert_unsafety is_unsafe)
+  | Pbigarraydim dim -> Pbigarraydim dim
+  | Pbswap16 -> Pbswap16
+  | Pint_as_pointer -> Pint_as_pointer
+  | Popaque -> Popaque
+
+  | Pbytes_to_string
+  | Pbytes_of_string
+  | Pctconst _
+  | Pignore
+  | Prevapply
+  | Pdirapply
+  | Pidentity
+  | Pgetglobal _
+  | Psetglobal _
+    ->
+      Misc.fatal_errorf "lambda primitive %a can't be converted to \
+                         clambda primitive"
+        Printlambda.primitive prim
diff --git a/middle_end/convert_primitives.mli b/middle_end/convert_primitives.mli
new file mode 100644
index 0000000000..8c3691268a
--- /dev/null
+++ b/middle_end/convert_primitives.mli
@@ -0,0 +1,17 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                       Pierre Chambart, OCamlPro                        *)
+(*           Mark Shinwell and Leo White, Jane Street Europe              *)
+(*                                                                        *)
+(*   Copyright 2017 OCamlPro SAS                                          *)
+(*   Copyright 2017 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+val convert : Lambda.primitive -> Clambda_primitives.primitive
diff --git a/middle_end/debuginfo.ml b/middle_end/debuginfo.ml
deleted file mode 100644
index 7a33902222..0000000000
--- a/middle_end/debuginfo.ml
+++ /dev/null
@@ -1,145 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2006 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-open! Int_replace_polymorphic_compare
-open Lexing
-open Location
-
-type item = {
-  dinfo_file: string;
-  dinfo_line: int;
-  dinfo_char_start: int;
-  dinfo_char_end: int;
-  dinfo_start_bol: int;
-  dinfo_end_bol: int;
-  dinfo_end_line: int;
-}
-
-type t = item list
-
-let none = []
-
-let is_none = function
-  | [] -> true
-  | _ :: _ -> false
-
-let to_string dbg =
-  match dbg with
-  | [] -> ""
-  | ds ->
-    let items =
-      List.map
-        (fun d ->
-           Printf.sprintf "%s:%d,%d-%d"
-             d.dinfo_file d.dinfo_line d.dinfo_char_start d.dinfo_char_end)
-        ds
-    in
-    "{" ^ String.concat ";" items ^ "}"
-
-let item_from_location loc =
-  let valid_endpos =
-    String.equal loc.loc_end.pos_fname loc.loc_start.pos_fname in
-  { dinfo_file = loc.loc_start.pos_fname;
-    dinfo_line = loc.loc_start.pos_lnum;
-    dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol;
-    dinfo_char_end =
-      if valid_endpos
-      then loc.loc_end.pos_cnum - loc.loc_start.pos_bol
-      else loc.loc_start.pos_cnum - loc.loc_start.pos_bol;
-    dinfo_start_bol = loc.loc_start.pos_bol;
-    dinfo_end_bol =
-      if valid_endpos then loc.loc_end.pos_bol
-      else loc.loc_start.pos_bol;
-    dinfo_end_line =
-      if valid_endpos then loc.loc_end.pos_lnum
-      else loc.loc_start.pos_lnum;
-  }
-
-let from_location loc =
-  if loc == Location.none then [] else [item_from_location loc]
-
-let to_location = function
-  | [] -> Location.none
-  | d :: _ ->
-    let loc_start =
-      { pos_fname = d.dinfo_file;
-        pos_lnum = d.dinfo_line;
-        pos_bol = d.dinfo_start_bol;
-        pos_cnum = d.dinfo_start_bol + d.dinfo_char_start;
-      } in
-    let loc_end =
-      { pos_fname = d.dinfo_file;
-        pos_lnum = d.dinfo_end_line;
-        pos_bol = d.dinfo_end_bol;
-        pos_cnum = d.dinfo_start_bol + d.dinfo_char_end;
-      } in
-    { loc_ghost = false; loc_start; loc_end; }
-
-let inline loc t =
-  if loc == Location.none then t
-  else (item_from_location loc) :: t
-
-let concat dbg1 dbg2 =
-  dbg1 @ dbg2
-
-(* CR-someday afrisch: FWIW, the current compare function does not seem very
-   good, since it reverses the two lists. I don't know how long the lists are,
-   nor if the specific currently implemented ordering is useful in other
-   contexts, but if one wants to use Map, a more efficient comparison should
-   be considered. *)
-let compare dbg1 dbg2 =
-  let rec loop ds1 ds2 =
-    match ds1, ds2 with
-    | [], [] -> 0
-    | _ :: _, [] -> 1
-    | [], _ :: _ -> -1
-    | d1 :: ds1, d2 :: ds2 ->
-      let c = String.compare d1.dinfo_file d2.dinfo_file in
-      if c <> 0 then c else
-      let c = compare d1.dinfo_line d2.dinfo_line in
-      if c <> 0 then c else
-      let c = compare d1.dinfo_char_end d2.dinfo_char_end in
-      if c <> 0 then c else
-      let c = compare d1.dinfo_char_start d2.dinfo_char_start in
-      if c <> 0 then c else
-      let c = compare d1.dinfo_start_bol d2.dinfo_start_bol in
-      if c <> 0 then c else
-      let c = compare d1.dinfo_end_bol d2.dinfo_end_bol in
-      if c <> 0 then c else
-      let c = compare d1.dinfo_end_line d2.dinfo_end_line in
-      if c <> 0 then c else
-      loop ds1 ds2
-  in
-  loop (List.rev dbg1) (List.rev dbg2)
-
-let hash t =
-  List.fold_left (fun hash item -> Hashtbl.hash (hash, item)) 0 t
-
-let rec print_compact ppf t =
-  let print_item item =
-    Format.fprintf ppf "%a:%i"
-      Location.print_filename item.dinfo_file
-      item.dinfo_line;
-    if item.dinfo_char_start >= 0 then begin
-      Format.fprintf ppf ",%i--%i" item.dinfo_char_start item.dinfo_char_end
-    end
-  in
-  match t with
-  | [] -> ()
-  | [item] -> print_item item
-  | item::t ->
-    print_item item;
-    Format.fprintf ppf ";";
-    print_compact ppf t
diff --git a/middle_end/debuginfo.mli b/middle_end/debuginfo.mli
deleted file mode 100644
index 4dc5e59906..0000000000
--- a/middle_end/debuginfo.mli
+++ /dev/null
@@ -1,46 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Gallium, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2006 Institut National de Recherche en Informatique et     *)
-(*     en Automatique.                                                    *)
-(*                                                                        *)
-(*   All rights reserved.  This file is distributed under the terms of    *)
-(*   the GNU Lesser General Public License version 2.1, with the          *)
-(*   special exception on linking described in the file LICENSE.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-type item = private {
-  dinfo_file: string;
-  dinfo_line: int;
-  dinfo_char_start: int;
-  dinfo_char_end: int;
-  dinfo_start_bol: int;
-  dinfo_end_bol: int;
-  dinfo_end_line: int;
-}
-
-type t = item list
-
-val none : t
-
-val is_none : t -> bool
-
-val to_string : t -> string
-
-val from_location : Location.t -> t
-
-val to_location : t -> Location.t
-
-val concat: t -> t -> t
-
-val inline: Location.t -> t -> t
-
-val compare : t -> t -> int
-
-val hash : t -> int
-
-val print_compact : Format.formatter -> t -> unit
diff --git a/middle_end/alias_analysis.ml b/middle_end/flambda/alias_analysis.ml
index fe97a36f51..fe97a36f51 100644
--- a/middle_end/alias_analysis.ml
+++ b/middle_end/flambda/alias_analysis.ml
diff --git a/middle_end/alias_analysis.mli b/middle_end/flambda/alias_analysis.mli
index 515daeffa3..515daeffa3 100644
--- a/middle_end/alias_analysis.mli
+++ b/middle_end/flambda/alias_analysis.mli
diff --git a/middle_end/allocated_const.ml b/middle_end/flambda/allocated_const.ml
index 78dc4ee103..78dc4ee103 100644
--- a/middle_end/allocated_const.ml
+++ b/middle_end/flambda/allocated_const.ml
diff --git a/middle_end/allocated_const.mli b/middle_end/flambda/allocated_const.mli
index 0bdbe49ec4..0bdbe49ec4 100644
--- a/middle_end/allocated_const.mli
+++ b/middle_end/flambda/allocated_const.mli
diff --git a/middle_end/augment_specialised_args.ml b/middle_end/flambda/augment_specialised_args.ml
index c3a3078512..c3a3078512 100644
--- a/middle_end/augment_specialised_args.ml
+++ b/middle_end/flambda/augment_specialised_args.ml
diff --git a/middle_end/augment_specialised_args.mli b/middle_end/flambda/augment_specialised_args.mli
index 5c48a12652..5c48a12652 100644
--- a/middle_end/augment_specialised_args.mli
+++ b/middle_end/flambda/augment_specialised_args.mli
diff --git a/middle_end/base_types/closure_element.ml b/middle_end/flambda/base_types/closure_element.ml
index 561e080396..561e080396 100644
--- a/middle_end/base_types/closure_element.ml
+++ b/middle_end/flambda/base_types/closure_element.ml
diff --git a/middle_end/base_types/closure_element.mli b/middle_end/flambda/base_types/closure_element.mli
index d78dd9b369..d78dd9b369 100644
--- a/middle_end/base_types/closure_element.mli
+++ b/middle_end/flambda/base_types/closure_element.mli
diff --git a/middle_end/base_types/closure_id.ml b/middle_end/flambda/base_types/closure_id.ml
index 466f59a237..466f59a237 100644
--- a/middle_end/base_types/closure_id.ml
+++ b/middle_end/flambda/base_types/closure_id.ml
diff --git a/middle_end/base_types/closure_id.mli b/middle_end/flambda/base_types/closure_id.mli
index 853a07f7f4..853a07f7f4 100644
--- a/middle_end/base_types/closure_id.mli
+++ b/middle_end/flambda/base_types/closure_id.mli
diff --git a/middle_end/base_types/closure_origin.ml b/middle_end/flambda/base_types/closure_origin.ml
index 2285c687e3..2285c687e3 100644
--- a/middle_end/base_types/closure_origin.ml
+++ b/middle_end/flambda/base_types/closure_origin.ml
diff --git a/middle_end/base_types/closure_origin.mli b/middle_end/flambda/base_types/closure_origin.mli
index 86fcd56cc6..86fcd56cc6 100644
--- a/middle_end/base_types/closure_origin.mli
+++ b/middle_end/flambda/base_types/closure_origin.mli
diff --git a/middle_end/base_types/export_id.ml b/middle_end/flambda/base_types/export_id.ml
index 681ac955af..681ac955af 100644
--- a/middle_end/base_types/export_id.ml
+++ b/middle_end/flambda/base_types/export_id.ml
diff --git a/middle_end/base_types/export_id.mli b/middle_end/flambda/base_types/export_id.mli
index 54c14418e4..54c14418e4 100644
--- a/middle_end/base_types/export_id.mli
+++ b/middle_end/flambda/base_types/export_id.mli
diff --git a/middle_end/base_types/id_types.ml b/middle_end/flambda/base_types/id_types.ml
index 6d2e274311..6d2e274311 100644
--- a/middle_end/base_types/id_types.ml
+++ b/middle_end/flambda/base_types/id_types.ml
diff --git a/middle_end/base_types/id_types.mli b/middle_end/flambda/base_types/id_types.mli
index 48ca037caf..48ca037caf 100644
--- a/middle_end/base_types/id_types.mli
+++ b/middle_end/flambda/base_types/id_types.mli
diff --git a/middle_end/base_types/mutable_variable.ml b/middle_end/flambda/base_types/mutable_variable.ml
index 07fe3152da..07fe3152da 100644
--- a/middle_end/base_types/mutable_variable.ml
+++ b/middle_end/flambda/base_types/mutable_variable.ml
diff --git a/middle_end/base_types/mutable_variable.mli b/middle_end/flambda/base_types/mutable_variable.mli
index 17fe208fe0..17fe208fe0 100644
--- a/middle_end/base_types/mutable_variable.mli
+++ b/middle_end/flambda/base_types/mutable_variable.mli
diff --git a/middle_end/base_types/set_of_closures_id.ml b/middle_end/flambda/base_types/set_of_closures_id.ml
index 681ac955af..681ac955af 100644
--- a/middle_end/base_types/set_of_closures_id.ml
+++ b/middle_end/flambda/base_types/set_of_closures_id.ml
diff --git a/middle_end/base_types/set_of_closures_id.mli b/middle_end/flambda/base_types/set_of_closures_id.mli
index 811cb66102..811cb66102 100644
--- a/middle_end/base_types/set_of_closures_id.mli
+++ b/middle_end/flambda/base_types/set_of_closures_id.mli
diff --git a/middle_end/base_types/set_of_closures_origin.ml b/middle_end/flambda/base_types/set_of_closures_origin.ml
index a5ef8c7c3d..a5ef8c7c3d 100644
--- a/middle_end/base_types/set_of_closures_origin.ml
+++ b/middle_end/flambda/base_types/set_of_closures_origin.ml
diff --git a/middle_end/base_types/set_of_closures_origin.mli b/middle_end/flambda/base_types/set_of_closures_origin.mli
index 4c9cfdcf80..4c9cfdcf80 100644
--- a/middle_end/base_types/set_of_closures_origin.mli
+++ b/middle_end/flambda/base_types/set_of_closures_origin.mli
diff --git a/middle_end/base_types/static_exception.ml b/middle_end/flambda/base_types/static_exception.ml
index 6cecae6328..6cecae6328 100644
--- a/middle_end/base_types/static_exception.ml
+++ b/middle_end/flambda/base_types/static_exception.ml
diff --git a/middle_end/base_types/static_exception.mli b/middle_end/flambda/base_types/static_exception.mli
index 88f690aa10..88f690aa10 100644
--- a/middle_end/base_types/static_exception.mli
+++ b/middle_end/flambda/base_types/static_exception.mli
diff --git a/middle_end/base_types/tag.ml b/middle_end/flambda/base_types/tag.ml
index cfa51ddbb2..cfa51ddbb2 100644
--- a/middle_end/base_types/tag.ml
+++ b/middle_end/flambda/base_types/tag.ml
diff --git a/middle_end/base_types/tag.mli b/middle_end/flambda/base_types/tag.mli
index 12ce55255c..12ce55255c 100644
--- a/middle_end/base_types/tag.mli
+++ b/middle_end/flambda/base_types/tag.mli
diff --git a/middle_end/base_types/var_within_closure.ml b/middle_end/flambda/base_types/var_within_closure.ml
index 466f59a237..466f59a237 100644
--- a/middle_end/base_types/var_within_closure.ml
+++ b/middle_end/flambda/base_types/var_within_closure.ml
diff --git a/middle_end/base_types/var_within_closure.mli b/middle_end/flambda/base_types/var_within_closure.mli
index 56f0af0ad6..56f0af0ad6 100644
--- a/middle_end/base_types/var_within_closure.mli
+++ b/middle_end/flambda/base_types/var_within_closure.mli
diff --git a/middle_end/flambda/build_export_info.ml b/middle_end/flambda/build_export_info.ml
new file mode 100644
index 0000000000..c3d811deea
--- /dev/null
+++ b/middle_end/flambda/build_export_info.ml
@@ -0,0 +1,711 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+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 new_value_closure_descr
+    : t
+    -> closure_id:Closure_id.t
+    -> set_of_closures: Export_info.value_set_of_closures
+    -> Export_id.t
+
+  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;
+        closure_table : Export_id.t Closure_id.Map.t ref;
+      }
+
+    let create_empty () =
+      { sym = Symbol.Map.empty;
+        ex_table = ref Export_id.Map.empty;
+        closure_table = ref Closure_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;
+      closure_table: Export_id.t Closure_id.Map.t ref;
+    }
+
+  let empty_of_global (env : Global.t) =
+    { var = Variable.Map.empty;
+      sym = env.sym;
+      ex_table = env.ex_table;
+      closure_table = env.closure_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
+      match
+        Compilenv.approx_for_global (Symbol.compilation_unit sym)
+      with
+      | None -> None
+      | Some export ->
+        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_value_closure_descr t ~closure_id ~set_of_closures =
+    match Closure_id.Map.find closure_id !(t.closure_table) with
+    | exception Not_found ->
+      let export_id =
+        new_descr t (Value_closure { closure_id; set_of_closures })
+      in
+      t.closure_table :=
+        Closure_id.Map.add closure_id export_id !(t.closure_table);
+      export_id
+    | export_id -> export_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 { 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, _value_kind), 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 _ -> 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;
+      Value_id (
+        Env.new_value_closure_descr env ~closure_id ~set_of_closures
+      )
+    | _ ->
+      (* It would be nice if this were [assert false], but owing to the fact
+         that this pass may propagate less information than for example
+         [Inline_and_simplify], we might end up here. *)
+      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);
+      Value_id (
+        Env.new_value_closure_descr env ~closure_id:move_to ~set_of_closures
+      )
+    | _ -> 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 (fun (external_var : Flambda.specialised_to) ->
+        Env.find_approx env external_var.var)
+      set.free_vars
+  in
+  let specialised_args_approx =
+    Variable.Map.map (fun (spec_to : Flambda.specialised_to) ->
+        Env.find_approx env spec_to.var)
+      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;
+        free_vars = set.free_vars;
+        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 export_id =
+          let closure_id = Closure_id.wrap fun_var in
+          let set_of_closures = initial_value_set_of_closures in
+          Env.new_value_closure_descr env ~closure_id ~set_of_closures
+        in
+        Export_info.Value_id export_id)
+      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;
+    free_vars = set.free_vars;
+    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_transient ~(backend : (module Backend_intf.S))
+      (program : Flambda.program) : Export_info.transient =
+  if !Clflags.opaque then
+    let compilation_unit = Compilenv.current_unit () in
+    let root_symbol = Compilenv.current_unit_symbol () in
+    Export_info.opaque_transient ~root_symbol ~compilation_unit
+  else
+    (* CR-soon pchambart: Should probably use that instead of the ident of
+       the module as global identifier.
+       mshinwell: Is "that" the variable "_global_symbol"?
+       Yes it is.  We are just assuming that the symbol produced from
+       the identifier of the module is the right one. *)
+    let _global_symbol, env =
+      describe_program (Env.Global.create_empty ()) program
+    in
+    let sets_of_closures_map =
+      Flambda_utils.all_sets_of_closures_map program
+    in
+    let function_declarations_map =
+      let set_of_closures_approx { Flambda. function_decls; _ } =
+        let recursive =
+          lazy
+            (Find_recursive_functions.in_function_declarations
+               function_decls ~backend)
+        in
+        let keep_body =
+          Inline_and_simplify_aux.keep_body_check
+            ~is_classic_mode:function_decls.is_classic_mode ~recursive
+        in
+        Simple_value_approx.function_declarations_approx
+          ~keep_body function_decls
+      in
+      Set_of_closures_id.Map.map set_of_closures_approx sets_of_closures_map
+    in
+    let unnested_values =
+      Env.Global.export_id_to_descr_map env
+    in
+    let invariant_params =
+      let invariant_params =
+        Set_of_closures_id.Map.map
+          (fun { Flambda. function_decls; _ } ->
+             if function_decls.is_classic_mode then begin
+               Variable.Map.empty
+             end else begin
+               Invariant_params.invariant_params_in_recursion
+                 ~backend function_decls
+             end)
+          (Flambda_utils.all_sets_of_closures_map program)
+      in
+      let export = Compilenv.approx_env () in
+      Export_id.Map.fold
+        (fun _eid (descr:Export_info.descr) invariant_params ->
+          match (descr : Export_info.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
+          | Export_info.Value_boxed_int (_, _)
+          | Value_block _
+          | Value_mutable_block _
+          | Value_int _
+          | Value_char _
+          | Value_constptr _
+          | Value_float _
+          | Value_float_array _
+          | Value_string _
+          | Value_unknown_descr ->
+            invariant_params)
+        unnested_values invariant_params
+    in
+    let recursive =
+      let recursive =
+        Set_of_closures_id.Map.map
+          (fun { Flambda. function_decls; _ } ->
+             if function_decls.is_classic_mode then begin
+               Variable.Set.empty
+             end else begin
+               Find_recursive_functions.in_function_declarations
+                 ~backend function_decls
+             end)
+          (Flambda_utils.all_sets_of_closures_map program)
+      in
+      let export = Compilenv.approx_env () in
+      Export_id.Map.fold
+        (fun _eid (descr:Export_info.descr) recursive ->
+          match (descr : Export_info.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.recursive
+            with
+            | exception Not_found ->
+              recursive
+            | (set : Variable.Set.t) ->
+              Set_of_closures_id.Map.add
+                set_of_closures_id set recursive
+            end
+          | Export_info.Value_boxed_int (_, _)
+          | Value_block _
+          | Value_mutable_block _
+          | Value_int _
+          | Value_char _
+          | Value_constptr _
+          | Value_float _
+          | Value_float_array _
+          | Value_string _
+          | Value_unknown_descr ->
+            recursive)
+        unnested_values recursive
+    in
+    let values = Export_info.nest_eid_map unnested_values in
+    let symbol_id = Env.Global.symbol_to_export_id_map env in
+    let { Traverse_for_exported_symbols.
+          set_of_closure_ids = relevant_set_of_closures;
+          symbols = relevant_symbols;
+          export_ids = relevant_export_ids;
+          set_of_closure_ids_keep_declaration =
+            relevant_set_of_closures_declaration_only;
+          relevant_local_closure_ids;
+          relevant_imported_closure_ids;
+          relevant_local_vars_within_closure;
+          relevant_imported_vars_within_closure;
+        } =
+      let closure_id_to_set_of_closures_id =
+        Set_of_closures_id.Map.fold
+          (fun set_of_closure_id
+            (function_declarations : Simple_value_approx.function_declarations)
+            acc ->
+              Variable.Map.fold
+                (fun fun_var _ acc ->
+                  let closure_id = Closure_id.wrap fun_var in
+                  Closure_id.Map.add closure_id set_of_closure_id acc)
+                function_declarations.funs
+                acc)
+          function_declarations_map
+          Closure_id.Map.empty
+      in
+      Traverse_for_exported_symbols.traverse
+        ~sets_of_closures_map
+        ~closure_id_to_set_of_closures_id
+        ~function_declarations_map
+        ~values:(Compilation_unit.Map.find (Compilenv.current_unit ()) values)
+        ~symbol_id
+        ~root_symbol:(Compilenv.current_unit_symbol ())
+    in
+    let sets_of_closures =
+      Set_of_closures_id.Map.filter_map
+        function_declarations_map
+        ~f:(fun key (fun_decls : Simple_value_approx.function_declarations) ->
+          if Set_of_closures_id.Set.mem key relevant_set_of_closures then
+            Some fun_decls
+          else if begin
+            Set_of_closures_id.Set.mem key
+              relevant_set_of_closures_declaration_only
+          end then begin
+            if fun_decls.is_classic_mode then
+              Some (Simple_value_approx.clear_function_bodies fun_decls)
+            else
+              Some fun_decls
+          end else begin
+            None
+          end)
+    in
+
+    let values =
+      Compilation_unit.Map.map (fun map ->
+          Export_id.Map.filter (fun key _ ->
+              Export_id.Set.mem key relevant_export_ids)
+            map)
+        values
+    in
+    let symbol_id =
+      Symbol.Map.filter
+        (fun key _ -> Symbol.Set.mem key relevant_symbols)
+        symbol_id
+    in
+    Export_info.create_transient ~values
+      ~symbol_id
+      ~sets_of_closures
+      ~invariant_params
+      ~recursive
+      ~relevant_local_closure_ids
+      ~relevant_imported_closure_ids
+      ~relevant_local_vars_within_closure
+      ~relevant_imported_vars_within_closure
diff --git a/middle_end/flambda/build_export_info.mli b/middle_end/flambda/build_export_info.mli
new file mode 100644
index 0000000000..0380604bf8
--- /dev/null
+++ b/middle_end/flambda/build_export_info.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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+(** Construct export information, for emission into .cmx files, from an
+    Flambda program. *)
+
+val build_transient :
+  backend:(module Backend_intf.S) ->
+  Flambda.program ->
+  Export_info.transient
diff --git a/middle_end/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml
index 9bdd30ead9..9bdd30ead9 100644
--- a/middle_end/closure_conversion.ml
+++ b/middle_end/flambda/closure_conversion.ml
diff --git a/middle_end/closure_conversion.mli b/middle_end/flambda/closure_conversion.mli
index f5fab0a7ed..f5fab0a7ed 100644
--- a/middle_end/closure_conversion.mli
+++ b/middle_end/flambda/closure_conversion.mli
diff --git a/middle_end/closure_conversion_aux.ml b/middle_end/flambda/closure_conversion_aux.ml
index cfcaf34d1b..cfcaf34d1b 100644
--- a/middle_end/closure_conversion_aux.ml
+++ b/middle_end/flambda/closure_conversion_aux.ml
diff --git a/middle_end/closure_conversion_aux.mli b/middle_end/flambda/closure_conversion_aux.mli
index f16f05f0d7..f16f05f0d7 100644
--- a/middle_end/closure_conversion_aux.mli
+++ b/middle_end/flambda/closure_conversion_aux.mli
diff --git a/middle_end/flambda/closure_offsets.ml b/middle_end/flambda/closure_offsets.ml
new file mode 100644
index 0000000000..51a09f02cb
--- /dev/null
+++ b/middle_end/flambda/closure_offsets.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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+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
diff --git a/middle_end/flambda/closure_offsets.mli b/middle_end/flambda/closure_offsets.mli
new file mode 100644
index 0000000000..7ecf9c276d
--- /dev/null
+++ b/middle_end/flambda/closure_offsets.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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+(** 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
diff --git a/middle_end/effect_analysis.ml b/middle_end/flambda/effect_analysis.ml
index d0cbd44180..d0cbd44180 100644
--- a/middle_end/effect_analysis.ml
+++ b/middle_end/flambda/effect_analysis.ml
diff --git a/middle_end/effect_analysis.mli b/middle_end/flambda/effect_analysis.mli
index b025bf0f87..b025bf0f87 100644
--- a/middle_end/effect_analysis.mli
+++ b/middle_end/flambda/effect_analysis.mli
diff --git a/middle_end/flambda/export_info.ml b/middle_end/flambda/export_info.ml
new file mode 100644
index 0000000000..22dbb6c583
--- /dev/null
+++ b/middle_end/flambda/export_info.ml
@@ -0,0 +1,555 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+module A = Simple_value_approx
+
+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 A.boxed_int * 'a -> descr
+  | Value_string of value_string
+  | Value_closure of value_closure
+  | Value_set_of_closures of value_set_of_closures
+  | Value_unknown_descr
+
+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;
+  free_vars : Flambda.specialised_to Variable.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_unknown_descr, Value_unknown_descr ->
+    true
+  | 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) ->
+    A.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_unknown_descr ),
+    ( 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_unknown_descr ) ->
+    false
+
+type t = {
+  sets_of_closures : A.function_declarations Set_of_closures_id.Map.t;
+  values : descr Export_id.Map.t Compilation_unit.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_closures : Closure_id.Set.t;
+  invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t;
+  recursive : Variable.Set.t Set_of_closures_id.Map.t;
+}
+
+type transient = {
+  sets_of_closures : A.function_declarations Set_of_closures_id.Map.t;
+  values : descr Export_id.Map.t Compilation_unit.Map.t;
+  symbol_id : Export_id.t Symbol.Map.t;
+  invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t;
+  recursive : Variable.Set.t Set_of_closures_id.Map.t;
+  relevant_local_closure_ids : Closure_id.Set.t;
+  relevant_imported_closure_ids : Closure_id.Set.t;
+  relevant_local_vars_within_closure  : Var_within_closure.Set.t;
+  relevant_imported_vars_within_closure : Var_within_closure.Set.t;
+}
+
+let empty : t = {
+  sets_of_closures = Set_of_closures_id.Map.empty;
+  values = Compilation_unit.Map.empty;
+  symbol_id = Symbol.Map.empty;
+  offset_fun = Closure_id.Map.empty;
+  offset_fv = Var_within_closure.Map.empty;
+  constant_closures = Closure_id.Set.empty;
+  invariant_params = Set_of_closures_id.Map.empty;
+  recursive = Set_of_closures_id.Map.empty;
+}
+
+let opaque_transient ~compilation_unit ~root_symbol : transient =
+  let export_id = Export_id.create compilation_unit in
+  let values =
+    let map = Export_id.Map.singleton export_id Value_unknown_descr in
+    Compilation_unit.Map.singleton compilation_unit map
+  in
+  let symbol_id = Symbol.Map.singleton root_symbol export_id in
+  { sets_of_closures = Set_of_closures_id.Map.empty;
+    values;
+    symbol_id;
+    invariant_params = Set_of_closures_id.Map.empty;
+    recursive = Set_of_closures_id.Map.empty;
+    relevant_local_closure_ids = Closure_id.Set.empty;
+    relevant_imported_closure_ids = Closure_id.Set.empty;
+    relevant_local_vars_within_closure = Var_within_closure.Set.empty;
+    relevant_imported_vars_within_closure = Var_within_closure.Set.empty;
+  }
+
+let create ~sets_of_closures ~values ~symbol_id
+      ~offset_fun ~offset_fv ~constant_closures
+      ~invariant_params ~recursive =
+  { sets_of_closures;
+    values;
+    symbol_id;
+    offset_fun;
+    offset_fv;
+    constant_closures;
+    invariant_params;
+    recursive;
+  }
+
+let create_transient
+      ~sets_of_closures ~values ~symbol_id ~invariant_params ~recursive
+      ~relevant_local_closure_ids ~relevant_imported_closure_ids
+      ~relevant_local_vars_within_closure
+      ~relevant_imported_vars_within_closure =
+  { sets_of_closures;
+    values;
+    symbol_id;
+    invariant_params;
+    recursive;
+    relevant_local_closure_ids;
+    relevant_imported_closure_ids;
+    relevant_local_vars_within_closure;
+    relevant_imported_vars_within_closure;
+  }
+
+let t_of_transient transient
+      ~program:_
+      ~local_offset_fun ~local_offset_fv
+      ~imported_offset_fun ~imported_offset_fv
+      ~constant_closures =
+  let offset_fun =
+    let fold_map set =
+      Closure_id.Map.fold (fun key value unchanged ->
+        if Closure_id.Set.mem key set then
+          Closure_id.Map.add key value unchanged
+        else
+          unchanged)
+    in
+    Closure_id.Map.empty
+    |> fold_map transient.relevant_local_closure_ids local_offset_fun
+    |> fold_map transient.relevant_imported_closure_ids imported_offset_fun
+  in
+  let offset_fv =
+    let fold_map set =
+      Var_within_closure.Map.fold (fun key value unchanged ->
+        if Var_within_closure.Set.mem key set then
+          Var_within_closure.Map.add key value unchanged
+        else
+          unchanged)
+    in
+    Var_within_closure.Map.empty
+    |> fold_map transient.relevant_local_vars_within_closure local_offset_fv
+    |> fold_map transient.relevant_imported_vars_within_closure
+         imported_offset_fv
+  in
+  { sets_of_closures = transient.sets_of_closures;
+    values = transient.values;
+    symbol_id = transient.symbol_id;
+    invariant_params = transient.invariant_params;
+    recursive = transient.recursive;
+    offset_fun;
+    offset_fv;
+    constant_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;
+    sets_of_closures =
+      Set_of_closures_id.Map.disjoint_union t1.sets_of_closures
+        t2.sets_of_closures;
+    symbol_id =
+      Symbol.Map.disjoint_union ~print:Export_id.print 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_closures =
+      Closure_id.Set.union t1.constant_closures t2.constant_closures;
+    invariant_params =
+      Set_of_closures_id.Map.disjoint_union
+        ~print:(Variable.Map.print Variable.Set.print)
+        ~eq:(Variable.Map.equal Variable.Set.equal)
+        t1.invariant_params t2.invariant_params;
+    recursive =
+      Set_of_closures_id.Map.disjoint_union
+        ~print:Variable.Set.print
+        ~eq:Variable.Set.equal
+        t1.recursive t2.recursive;
+  }
+
+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_raw_approx ppf approx =
+  let fprintf = Format.fprintf in
+  match approx with
+  | Value_unknown -> fprintf ppf "(Unknown)"
+  | Value_id export_id -> fprintf ppf "(Id %a)" Export_id.print export_id
+  | Value_symbol symbol -> fprintf ppf "(Symbol %a)" Symbol.print symbol
+
+let print_value_set_of_closures ppf (t : value_set_of_closures) =
+  let print_bound_vars ppf bound_vars =
+    Format.fprintf ppf "(%a)"
+      (Var_within_closure.Map.print print_raw_approx)
+      bound_vars
+  in
+  let print_free_vars ppf free_vars =
+    Format.fprintf ppf "(%a)"
+      (Variable.Map.print Flambda.print_specialised_to)
+      free_vars
+  in
+  let print_results ppf results =
+    Format.fprintf ppf "(%a)" (Closure_id.Map.print print_raw_approx) results
+  in
+  let print_aliased_symbol ppf aliased_symbol =
+    match aliased_symbol with
+    | None -> Format.fprintf ppf "<None>"
+    | Some symbol -> Format.fprintf ppf "(%a)" Symbol.print symbol
+  in
+  Format.fprintf ppf
+    "((set_of_closures_id %a) \
+     (bound_vars %a) \
+     (free_vars %a) \
+     (results %a) \
+     (aliased_symbol %a))"
+    Set_of_closures_id.print t.set_of_closures_id
+    print_bound_vars t.bound_vars
+    print_free_vars t.free_vars
+    print_results t.results
+    print_aliased_symbol t.aliased_symbol
+
+let print_value_closure ppf (t : value_closure) =
+  Format.fprintf ppf "((closure_id %a) (set_of_closures %a))"
+    Closure_id.print t.closure_id
+    print_value_set_of_closures t.set_of_closures
+
+let print_value_float_array_contents
+      ppf (value : value_float_array_contents) =
+  match value with
+  | Unknown_or_mutable -> Format.fprintf ppf "(Unknown_or_mutable)"
+  | Contents _ -> Format.fprintf ppf "(Contents ...)"
+
+let print_value_float_array ppf (value : value_float_array) =
+  Format.fprintf ppf "((size %d) (contents %a))"
+    value.size
+    print_value_float_array_contents value.contents
+
+let print_value_string_contents ppf (value : value_string_contents) =
+  match value with
+  | Unknown_or_mutable -> Format.fprintf ppf "(Unknown_or_mutable)"
+  | Contents _ -> Format.fprintf ppf "(Contents ...)"
+
+let print_value_string ppf (value : value_string) =
+  Format.fprintf ppf "((size %d) (contents %a))"
+    value.size
+    print_value_string_contents value.contents
+
+let print_raw_descr ppf descr =
+  let fprintf = Format.fprintf in
+  let print_approx_array ppf arr =
+    Array.iter (fun approx -> fprintf ppf "%a " print_raw_approx approx) arr
+  in
+  match descr with
+  | Value_block (tag, approx_array) ->
+    fprintf ppf "(Value_block (%a %a))"
+      Tag.print tag
+      print_approx_array approx_array
+  | Value_mutable_block (tag, i) ->
+    fprintf ppf "(Value_mutable-block (%a %d))" Tag.print tag i
+  | Value_int i -> fprintf ppf "(Value_int %d)" i
+  | Value_char c -> fprintf ppf "(Value_char %c)" c
+  | Value_constptr p -> fprintf ppf "(Value_constptr  %d)" p
+  | Value_float f -> fprintf ppf "(Value_float %.3f)" f
+  | Value_float_array value_float_array ->
+    fprintf ppf "(Value_float_array %a)"
+      print_value_float_array value_float_array
+  | Value_boxed_int _ ->
+    fprintf ppf "(Value_Boxed_int)"
+  | Value_string value_string ->
+    fprintf ppf "(Value_string %a)" print_value_string value_string
+  | Value_closure value_closure ->
+    fprintf ppf "(Value_closure %a)"
+      print_value_closure value_closure
+  | Value_set_of_closures value_set_of_closures ->
+    fprintf ppf "(Value_set_of_closures %a)"
+    print_value_set_of_closures value_set_of_closures
+  | Value_unknown_descr -> fprintf ppf "(Value_unknown_descr)"
+
+let print_approx_components ppf ~symbol_id ~values
+      (root_symbols : Symbol.t list) =
+  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) ->
+      begin match t with
+      | A.Int32 -> Format.fprintf ppf "%li" i
+      | A.Int64 -> Format.fprintf ppf "%Li" i
+      | A.Nativeint -> Format.fprintf ppf "%ni" i
+      end
+    | Value_unknown_descr -> Format.fprintf ppf "?"
+  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; results } =
+    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 => %a}"
+        Set_of_closures_id.print set_of_closures_id
+        print_binding bound_vars
+        print_alias aliased_symbol
+        (Closure_id.Map.print print_approx) results
+    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 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 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
+  List.iter (fun s -> Queue.push s symbols_to_print) root_symbols;
+  fprintf ppf "@[<hov 2>Globals:@ ";
+  fprintf ppf "@]@ @[<hov 2>Symbols:@ ";
+  print_recorded_symbols ();
+  fprintf ppf "@]"
+
+let print_approx ppf ((t : t), symbols) =
+  let symbol_id = t.symbol_id in
+  let values = t.values in
+  print_approx_components ppf ~symbol_id ~values symbols
+
+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_functions ppf (t : t) =
+  Set_of_closures_id.Map.print
+    A.print_function_declarations ppf
+    t.sets_of_closures
+
+let print_all ppf ((t, root_symbols) : t * Symbol.t list) =
+  let fprintf = Format.fprintf in
+  fprintf ppf "approxs@ %a@.@."
+    print_approx (t, root_symbols);
+  fprintf ppf "functions@ %a@.@."
+    print_functions t
diff --git a/middle_end/flambda/export_info.mli b/middle_end/flambda/export_info.mli
new file mode 100644
index 0000000000..f93698be4f
--- /dev/null
+++ b/middle_end/flambda/export_info.mli
@@ -0,0 +1,195 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+(** Exported information (that is to say, information written into a .cmx
+    file) about a compilation unit. *)
+
+module A = Simple_value_approx
+
+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 A.boxed_int * 'a -> descr
+  | Value_string of value_string
+  | Value_closure of value_closure
+  | Value_set_of_closures of value_set_of_closures
+  | Value_unknown_descr
+
+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;
+  free_vars : Flambda.specialised_to Variable.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 : A.function_declarations Set_of_closures_id.Map.t;
+  (** Code of exported functions indexed by set of closures IDs. *)
+  values : descr Export_id.Map.t Compilation_unit.Map.t;
+  (** Structure of exported values. *)
+  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_closures : Closure_id.Set.t;
+  (* CR-soon 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. *)
+  recursive : Variable.Set.t Set_of_closures_id.Map.t;
+}
+
+type transient = private {
+  sets_of_closures : A.function_declarations Set_of_closures_id.Map.t;
+  values : descr Export_id.Map.t Compilation_unit.Map.t;
+  symbol_id : Export_id.t Symbol.Map.t;
+  invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t;
+  recursive : Variable.Set.t Set_of_closures_id.Map.t;
+  relevant_local_closure_ids : Closure_id.Set.t;
+  relevant_imported_closure_ids : Closure_id.Set.t;
+  relevant_local_vars_within_closure  : Var_within_closure.Set.t;
+  relevant_imported_vars_within_closure : Var_within_closure.Set.t;
+}
+
+(** Export information for a compilation unit that exports nothing. *)
+val empty : t
+
+val opaque_transient
+  : compilation_unit:Compilation_unit.t
+  -> root_symbol:Symbol.t
+  -> transient
+
+(** Create a new export information structure. *)
+val create
+   : sets_of_closures:(A.function_declarations Set_of_closures_id.Map.t)
+  -> values:descr Export_id.Map.t Compilation_unit.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_closures:Closure_id.Set.t
+  -> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t
+  -> recursive:Variable.Set.t Set_of_closures_id.Map.t
+  -> t
+
+val create_transient
+   : sets_of_closures:(A.function_declarations Set_of_closures_id.Map.t)
+  -> values:descr Export_id.Map.t Compilation_unit.Map.t
+  -> symbol_id:Export_id.t Symbol.Map.t
+  -> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t
+  -> recursive:Variable.Set.t Set_of_closures_id.Map.t
+  -> relevant_local_closure_ids: Closure_id.Set.t
+  -> relevant_imported_closure_ids : Closure_id.Set.t
+  -> relevant_local_vars_within_closure : Var_within_closure.Set.t
+  -> relevant_imported_vars_within_closure : Var_within_closure.Set.t
+  -> transient
+
+(* 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 t_of_transient
+   : transient
+  -> program: Flambda.program
+  -> local_offset_fun:int Closure_id.Map.t
+  -> local_offset_fv:int Var_within_closure.Map.t
+  -> imported_offset_fun:int Closure_id.Map.t
+  -> imported_offset_fv:int Var_within_closure.Map.t
+  -> constant_closures:Closure_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_components
+  : Format.formatter
+  -> symbol_id: Export_id.t Symbol.Map.t
+  -> values: descr Export_id.Map.t Compilation_unit.Map.t
+  -> Symbol.t list
+  -> unit
+val print_approx : Format.formatter -> t * Symbol.t list -> unit
+val print_functions : Format.formatter -> t -> unit
+val print_offsets : Format.formatter -> t -> unit
+val print_all : Format.formatter -> t * Symbol.t list -> unit
+
+(** Prints approx and descr as it is, without recursively looking up
+    [Export_id.t] *)
+val print_raw_approx : Format.formatter -> approx -> unit
+val print_raw_descr  : Format.formatter -> descr -> unit
diff --git a/middle_end/flambda/export_info_for_pack.ml b/middle_end/flambda/export_info_for_pack.ml
new file mode 100644
index 0000000000..42a8155347
--- /dev/null
+++ b/middle_end/flambda/export_info_for_pack.ml
@@ -0,0 +1,231 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+module A = Simple_value_approx
+
+let rename_id_state = Export_id.Tbl.create 100
+let rename_set_of_closures_id_state = Set_of_closures_id.Tbl.create 10
+let imported_function_declarations_table =
+  (Set_of_closures_id.Tbl.create 10
+   : A.function_declarations Set_of_closures_id.Tbl.t)
+
+(* 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_id_for_pack units pack
+    (set_of_closures_id : Set_of_closures_id.t)
+      : Set_of_closures_id.t =
+  let compilation_unit =
+    Set_of_closures_id.get_compilation_unit set_of_closures_id
+  in
+  if Compilation_unit.Set.mem compilation_unit units then
+    Set_of_closures_id.Tbl.memoize
+      rename_set_of_closures_id_state
+      (fun _ ->
+         Set_of_closures_id.create
+           ?name:(Set_of_closures_id.name set_of_closures_id)
+           pack)
+      set_of_closures_id
+  else set_of_closures_id
+
+let import_set_of_closures_origin_for_pack units pack
+    (set_of_closures_origin : Set_of_closures_origin.t)
+    : Set_of_closures_origin.t =
+  Set_of_closures_origin.rename
+    (import_set_of_closures_id_for_pack units pack)
+    set_of_closures_origin
+
+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 =
+      import_set_of_closures_id_for_pack units pack
+        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;
+    free_vars = set_of_closures.free_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)
+  | Value_unknown_descr -> Value_unknown_descr
+
+let rec 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)
+      | Set_of_closures set_of_closures ->
+        let set_of_closures =
+          Flambda.create_set_of_closures
+            ~free_vars:set_of_closures.free_vars
+            ~specialised_args:set_of_closures.specialised_args
+            ~direct_call_surrogates:set_of_closures.direct_call_surrogates
+            ~function_decls:
+              (import_function_declarations_for_pack_aux units pack
+                 set_of_closures.function_decls)
+        in
+        Set_of_closures set_of_closures
+      | e -> e)
+    expr
+
+and import_function_declarations_for_pack_aux 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
+          ~specialise:function_decl.specialise
+          ~is_a_functor:function_decl.is_a_functor
+          ~closure_origin:function_decl.closure_origin)
+      function_decls.funs
+  in
+  Flambda.import_function_declarations_for_pack
+    (Flambda.update_function_declarations function_decls ~funs)
+    (import_set_of_closures_id_for_pack units pack)
+    (import_set_of_closures_origin_for_pack units pack)
+
+let import_function_declarations_for_pack_aux units pack
+      (function_decls : A.function_declarations) : A.function_declarations =
+  let funs =
+    Variable.Map.map
+      (fun (function_decl : A.function_declaration) ->
+         A.update_function_declaration_body function_decl
+           (fun body -> import_code_for_pack units pack body))
+      function_decls.funs
+  in
+  A.import_function_declarations_for_pack
+    (A.update_function_declarations function_decls ~funs)
+    (import_set_of_closures_id_for_pack units pack)
+    (import_set_of_closures_origin_for_pack units pack)
+
+let import_function_declarations_approx_for_pack units pack
+      (function_decls: A.function_declarations) =
+  let original_set_of_closures_id = function_decls.set_of_closures_id in
+  try
+    Set_of_closures_id.Tbl.find imported_function_declarations_table
+      original_set_of_closures_id
+  with Not_found ->
+    let function_decls =
+      import_function_declarations_for_pack_aux units pack function_decls
+    in
+    Set_of_closures_id.Tbl.add
+      imported_function_declarations_table
+      original_set_of_closures_id
+      function_decls;
+    function_decls
+
+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_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 import_set_of_closures_id =
+    import_set_of_closures_id_for_pack pack_units pack
+  in
+  let import_function_declarations =
+    import_function_declarations_approx_for_pack pack_units pack
+  in
+  let sets_of_closures =
+    Set_of_closures_id.Map.map_keys import_set_of_closures_id
+      (Set_of_closures_id.Map.map
+         import_function_declarations
+         exp.sets_of_closures)
+  in
+  Export_info.create ~sets_of_closures
+    ~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_closures:exp.constant_closures
+    ~invariant_params:
+      (Set_of_closures_id.Map.map_keys import_set_of_closures_id
+         exp.invariant_params)
+    ~recursive:
+      (Set_of_closures_id.Map.map_keys import_set_of_closures_id
+         exp.recursive)
+
+let clear_import_state () =
+  Set_of_closures_id.Tbl.clear imported_function_declarations_table;
+  Set_of_closures_id.Tbl.clear rename_set_of_closures_id_state;
+  Export_id.Tbl.clear rename_id_state
diff --git a/middle_end/flambda/export_info_for_pack.mli b/middle_end/flambda/export_info_for_pack.mli
new file mode 100644
index 0000000000..2ba3a35d8b
--- /dev/null
+++ b/middle_end/flambda/export_info_for_pack.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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+(** 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
diff --git a/middle_end/extract_projections.ml b/middle_end/flambda/extract_projections.ml
index 33cd473ecd..33cd473ecd 100644
--- a/middle_end/extract_projections.ml
+++ b/middle_end/flambda/extract_projections.ml
diff --git a/middle_end/extract_projections.mli b/middle_end/flambda/extract_projections.mli
index 47456bda0a..47456bda0a 100644
--- a/middle_end/extract_projections.mli
+++ b/middle_end/flambda/extract_projections.mli
diff --git a/middle_end/find_recursive_functions.ml b/middle_end/flambda/find_recursive_functions.ml
index e69433039f..e69433039f 100644
--- a/middle_end/find_recursive_functions.ml
+++ b/middle_end/flambda/find_recursive_functions.ml
diff --git a/middle_end/find_recursive_functions.mli b/middle_end/flambda/find_recursive_functions.mli
index 3c2dd5b1fb..3c2dd5b1fb 100644
--- a/middle_end/find_recursive_functions.mli
+++ b/middle_end/flambda/find_recursive_functions.mli
diff --git a/middle_end/flambda.ml b/middle_end/flambda/flambda.ml
index 243e2e3f9c..243e2e3f9c 100644
--- a/middle_end/flambda.ml
+++ b/middle_end/flambda/flambda.ml
diff --git a/middle_end/flambda.mli b/middle_end/flambda/flambda.mli
index 325c15ee1c..325c15ee1c 100644
--- a/middle_end/flambda.mli
+++ b/middle_end/flambda/flambda.mli
diff --git a/middle_end/flambda_invariants.ml b/middle_end/flambda/flambda_invariants.ml
index 250a2e9af7..250a2e9af7 100644
--- a/middle_end/flambda_invariants.ml
+++ b/middle_end/flambda/flambda_invariants.ml
diff --git a/middle_end/flambda_invariants.mli b/middle_end/flambda/flambda_invariants.mli
index 252578e88e..252578e88e 100644
--- a/middle_end/flambda_invariants.mli
+++ b/middle_end/flambda/flambda_invariants.mli
diff --git a/middle_end/flambda_iterators.ml b/middle_end/flambda/flambda_iterators.ml
index a69575da63..a69575da63 100644
--- a/middle_end/flambda_iterators.ml
+++ b/middle_end/flambda/flambda_iterators.ml
diff --git a/middle_end/flambda_iterators.mli b/middle_end/flambda/flambda_iterators.mli
index 02fe685097..02fe685097 100644
--- a/middle_end/flambda_iterators.mli
+++ b/middle_end/flambda/flambda_iterators.mli
diff --git a/middle_end/middle_end.ml b/middle_end/flambda/flambda_middle_end.ml
index e604a3285b..e604a3285b 100644
--- a/middle_end/middle_end.ml
+++ b/middle_end/flambda/flambda_middle_end.ml
diff --git a/middle_end/middle_end.mli b/middle_end/flambda/flambda_middle_end.mli
index 584cb45a98..584cb45a98 100644
--- a/middle_end/middle_end.mli
+++ b/middle_end/flambda/flambda_middle_end.mli
diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml
new file mode 100644
index 0000000000..2f60f9fcfc
--- /dev/null
+++ b/middle_end/flambda/flambda_to_clambda.ml
@@ -0,0 +1,749 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+module V = Backend_var
+module VP = Backend_var.With_provenance
+
+type 'a for_one_or_more_units = {
+  fun_offset_table : int Closure_id.Map.t;
+  fv_offset_table : int Var_within_closure.Map.t;
+  constant_closures : Closure_id.Set.t;
+  closures: Closure_id.Set.t;
+}
+
+type t = {
+  current_unit :
+    Set_of_closures_id.t for_one_or_more_units;
+  imported_units :
+    Simple_value_approx.function_declarations for_one_or_more_units;
+}
+
+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 is_function_constant t closure_id =
+  if Closure_id.Set.mem closure_id t.current_unit.closures then
+    Closure_id.Set.mem closure_id t.current_unit.constant_closures
+  else if Closure_id.Set.mem closure_id t.imported_units.closures then
+    Closure_id.Set.mem closure_id t.imported_units.constant_closures
+  else
+    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 -> V.t * t
+  val ident_for_var_exn : t -> Variable.t -> V.t
+
+  val add_fresh_mutable_ident : t -> Mutable_variable.t -> V.t * t
+  val ident_for_mutable_var_exn : t -> Mutable_variable.t -> V.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 : V.t Variable.Map.t;
+      mutable_var : V.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 = V.create_local (Variable.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 = V.create_local (Mutable_variable.name 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; _ } ->
+    (* TODO: synthesize proper value_kind *)
+    let id, env_body = Env.add_fresh_ident env var in
+    Ulet (Immutable, Pgenval, VP.create id,
+      to_clambda_named t env var defining_expr,
+      to_clambda t env_body body)
+  | Let_mutable { var = mut_var; initial_value = var; body; contents_kind } ->
+    let id, env_body = Env.add_fresh_mutable_ident env mut_var in
+    let def = subst_var env var in
+    Ulet (Mutable, contents_kind, VP.create 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) ->
+          VP.create 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 } ->
+    (* The closure _parameter_ of the function is added by cmmgen.
+       At the call site, for a direct call, the closure argument must be
+       explicitly added (by [to_clambda_direct_apply]); there is no special
+       handling of such in the direct call primitive.
+       For an indirect call, we do not need to do anything here; Cmmgen will
+       do the equivalent of the previous paragraph when it generates a direct
+       call to [caml_apply]. *)
+    to_clambda_direct_apply t func args direct_func dbg env
+  | Apply { func; args; kind = Indirect; dbg = dbg } ->
+    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;
+        },
+        Debuginfo.none)  (* debug info will be added by GPR#855 *)
+    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, (VP.create id, Lambda.Pgenval) :: 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, VP.create 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 (VP.create 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 } ->
+    (* Note that we must use [build_uoffset] to ensure that we do not generate
+       a [Uoffset] construction in the event that the offset is zero, otherwise
+       we might break pattern matches in Cmmgen (in particular for the
+       compilation of "let rec"). *)
+    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 (Popaque, 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 store = Flambda_utils.Switch_storer.mk_store () in
+  let default_action =
+    match default with
+    | Some def when List.length cases < num_keys ->
+      store.act_store () def
+    | _ -> -1
+  in
+  let index = Array.make num_keys default_action in
+  let smallest_key = ref num_keys in
+  List.iter
+    (fun (key, lam) ->
+      index.(key) <- store.act_store () lam;
+      smallest_key := min key !smallest_key
+    )
+    cases;
+  if !smallest_key < num_keys then begin
+    let action = ref index.(!smallest_key) in
+    Array.iteri
+      (fun i act ->
+         if act >= 0 then action := act else index.(i) <- !action)
+      index
+  end;
+  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
+    (* Remove the closure argument if the closure is closed.  (Note that the
+       closure argument is always a variable, so we can be sure we are not
+       dropping any side effects.) *)
+    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 = V.create_local "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 (Parameter.var var) in
+          env, id :: params)
+        function_decl.params (env, [])
+    in
+    { label = Compilenv.function_label closure_id;
+      arity = Flambda_utils.function_arity function_decl;
+      params =
+        List.map
+          (fun var -> VP.create var, Lambda.Pgenval)
+          (params @ [env_var]);
+      return = Lambda.Pgenval;
+      body = to_clambda t env_body function_decl.body;
+      dbg = function_decl.dbg;
+      env = Some env_var;
+    }
+  in
+  let funs = List.map to_clambda_function all_functions in
+  let free_vars =
+    Variable.Map.bindings (Variable.Map.map (
+      fun (free_var : Flambda.specialised_to) ->
+        subst_var env free_var.var) 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 (Parameter.var 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 = List.map (fun var -> VP.create var, Lambda.Pgenval) params;
+      return = Lambda.Pgenval;
+      body = to_clambda t env_body function_decl.body;
+      dbg = function_decl.dbg;
+      env = None;
+    }
+  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.map (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, Root_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 *
+          Clambda.preallocated_block list =
+    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) ->
+      let fields =
+        List.mapi (fun i field ->
+            i, field,
+            Initialize_symbol_to_let_symbol.constant_field field)
+          fields
+      in
+      let init_fields =
+        List.filter_map (function
+            | (i, field, None) -> Some (i, field)
+            | (_, _, Some _) -> None)
+          fields
+      in
+      let constant_fields =
+        List.map (fun (_, _, constant_field) ->
+            match constant_field with
+            | None -> None
+            | Some (Flambda.Const const) ->
+                let n =
+                  match const with
+                  | Int i -> i
+                  | Char c -> Char.code c
+                  | Const_pointer i -> i
+                in
+                Some (Clambda.Uconst_field_int n)
+            | Some (Flambda.Symbol sym) ->
+                let lbl = Linkage_name.to_string (Symbol.label sym) in
+                Some (Clambda.Uconst_field_ref lbl))
+          fields
+      in
+      let e1 = to_clambda_initialize_symbol t env symbol init_fields in
+      let preallocated_block : Clambda.preallocated_block =
+        { symbol = Linkage_name.to_string (Symbol.label symbol);
+          exported = true;
+          tag = Tag.to_int tag;
+          fields = constant_fields;
+          provenance = None;
+        }
+      in
+      let e2, constants, preallocated_blocks = loop env constants program in
+      Usequence (e1, e2), constants, preallocated_block :: preallocated_blocks
+    | Effect (expr, program) ->
+      let e1 = to_clambda t env expr in
+      let e2, constants, preallocated_blocks = loop env constants program in
+      Usequence (e1, e2), constants, preallocated_blocks
+    | 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_transient) : result =
+  let current_unit =
+    let closures =
+      Closure_id.Map.keys (Flambda_utils.make_closure_map program)
+    in
+    let constant_closures =
+      Flambda_utils.all_lifted_constant_closures program
+    in
+    let offsets = Closure_offsets.compute program in
+    { fun_offset_table = offsets.function_offsets;
+      fv_offset_table = offsets.free_variable_offsets;
+      constant_closures;
+      closures;
+    }
+  in
+  let imported_units =
+    let imported = Compilenv.approx_env () in
+    let closures =
+      Set_of_closures_id.Map.fold
+        (fun (_ : Set_of_closures_id.t) fun_decls acc ->
+           Variable.Map.fold
+             (fun var (_ : Simple_value_approx.function_declaration) acc ->
+               let closure_id = Closure_id.wrap var in
+               Closure_id.Set.add closure_id acc)
+             fun_decls.Simple_value_approx.funs
+             acc)
+        imported.sets_of_closures
+        Closure_id.Set.empty
+    in
+    { fun_offset_table = imported.offset_fun;
+      fv_offset_table = imported.offset_fv;
+      constant_closures = imported.constant_closures;
+      closures;
+    }
+  in
+  let t = { current_unit; imported_units; } in
+  let expr, structured_constants, preallocated_blocks =
+    to_clambda_program t Env.empty Symbol.Map.empty program
+  in
+  let exported =
+    Export_info.t_of_transient exported_transient
+      ~program
+      ~local_offset_fun:current_unit.fun_offset_table
+      ~local_offset_fv:current_unit.fv_offset_table
+      ~imported_offset_fun:imported_units.fun_offset_table
+      ~imported_offset_fv:imported_units.fv_offset_table
+      ~constant_closures:current_unit.constant_closures
+  in
+  { expr; preallocated_blocks; structured_constants; exported; }
diff --git a/middle_end/flambda/flambda_to_clambda.mli b/middle_end/flambda/flambda_to_clambda.mli
new file mode 100644
index 0000000000..8c493d40d6
--- /dev/null
+++ b/middle_end/flambda/flambda_to_clambda.mli
@@ -0,0 +1,38 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+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.transient -> result
diff --git a/middle_end/flambda_utils.ml b/middle_end/flambda/flambda_utils.ml
index c204f5e67c..c204f5e67c 100644
--- a/middle_end/flambda_utils.ml
+++ b/middle_end/flambda/flambda_utils.ml
diff --git a/middle_end/flambda_utils.mli b/middle_end/flambda/flambda_utils.mli
index 0f7b318627..0f7b318627 100644
--- a/middle_end/flambda_utils.mli
+++ b/middle_end/flambda/flambda_utils.mli
diff --git a/middle_end/freshening.ml b/middle_end/flambda/freshening.ml
index 891861a33e..891861a33e 100644
--- a/middle_end/freshening.ml
+++ b/middle_end/flambda/freshening.ml
diff --git a/middle_end/freshening.mli b/middle_end/flambda/freshening.mli
index 1550797ac1..1550797ac1 100644
--- a/middle_end/freshening.mli
+++ b/middle_end/flambda/freshening.mli
diff --git a/middle_end/flambda/import_approx.ml b/middle_end/flambda/import_approx.ml
new file mode 100644
index 0000000000..64fbbb8bff
--- /dev/null
+++ b/middle_end/flambda/import_approx.ml
@@ -0,0 +1,222 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+module A = Simple_value_approx
+
+let import_set_of_closures =
+  let import_function_declarations (clos : A.function_declarations)
+        : A.function_declarations =
+    (* CR-soon 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 : A.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 : A.function_declaration) ->
+        A.update_function_declaration_body function_decl
+          (Flambda_iterators.map_toplevel_named f_named))
+        clos.funs
+    in
+    A.update_function_declarations clos ~funs
+  in
+  let aux set_of_closures_id =
+    match
+      Compilenv.approx_for_global
+        (Set_of_closures_id.get_compilation_unit set_of_closures_id)
+    with
+    | None -> None
+    | Some ex_info ->
+      try
+        let function_declarations =
+          Set_of_closures_id.Map.find set_of_closures_id
+            ex_info.sets_of_closures
+        in
+        Some (import_function_declarations function_declarations)
+      with Not_found ->
+        Misc.fatal_error "Cannot find set of closures"
+  in
+  Set_of_closures_id.Tbl.memoize Compilenv.imported_sets_of_closures_table aux
+
+let rec import_ex ex =
+  let import_value_set_of_closures ~set_of_closures_id ~bound_vars ~free_vars
+        ~(ex_info : Export_info.t) ~what : A.value_set_of_closures option =
+    let bound_vars = Var_within_closure.Map.map import_approx bound_vars in
+    match import_set_of_closures set_of_closures_id with
+    | None -> None
+    | Some function_decls ->
+      (* CR-someday xclerc: add a test to the test suite to ensure that
+         classic mode behaves as expected. *)
+      let is_classic_mode = function_decls.is_classic_mode in
+      let invariant_params =
+        match
+          Set_of_closures_id.Map.find set_of_closures_id
+            ex_info.invariant_params
+        with
+        | exception Not_found ->
+          if is_classic_mode then
+            Variable.Map.empty
+          else
+            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
+        | found -> found
+      in
+      let recursive =
+        match
+          Set_of_closures_id.Map.find set_of_closures_id ex_info.recursive
+        with
+        | exception Not_found ->
+          if is_classic_mode then
+            Variable.Set.empty
+          else
+            Misc.fatal_errorf "Set of closures ID %a not found in \
+                               recursive (when importing [%a: %s])"
+              Set_of_closures_id.print set_of_closures_id
+              Export_id.print ex
+              what
+        | found -> found
+      in
+      Some (A.create_value_set_of_closures
+        ~function_decls
+        ~bound_vars
+        ~free_vars
+        ~invariant_params:(lazy invariant_params)
+        ~recursive:(lazy recursive)
+        ~specialised_args:Variable.Map.empty
+        ~freshening:Freshening.Project_var.empty
+        ~direct_call_surrogates:Closure_id.Map.empty)
+  in
+  let compilation_unit = Export_id.get_compilation_unit ex in
+  match Compilenv.approx_for_global compilation_unit with
+  | None -> A.value_unknown Other
+  | Some ex_info ->
+    match Export_info.find_description ex_info ex with
+    | exception Not_found ->
+      Misc.fatal_errorf "Cannot find export id %a" Export_id.print ex
+    | Value_unknown_descr -> 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
+          (Array.map (function
+             | None -> A.value_any_float
+             | Some f -> A.value_float f)
+             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; free_vars; aliased_symbol } } ->
+      let value_set_of_closures =
+        import_value_set_of_closures
+          ~set_of_closures_id ~bound_vars ~free_vars ~ex_info
+          ~what:(Format.asprintf "Value_closure %a" Closure_id.print closure_id)
+      in
+      begin match value_set_of_closures with
+      | None -> A.value_unresolved (Set_of_closures_id set_of_closures_id)
+      | Some value_set_of_closures ->
+        A.value_closure ?set_of_closures_symbol:aliased_symbol
+          value_set_of_closures closure_id
+      end
+    | Value_set_of_closures
+        { set_of_closures_id; bound_vars; free_vars; aliased_symbol } ->
+      let value_set_of_closures =
+        import_value_set_of_closures ~set_of_closures_id
+          ~bound_vars ~free_vars ~ex_info ~what:"Value_set_of_closures"
+      in
+      match value_set_of_closures with
+      | None ->
+        A.value_unresolved (Set_of_closures_id set_of_closures_id)
+      | Some value_set_of_closures ->
+        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 begin
+    let compilation_unit = Symbol.compilation_unit sym in
+    match Compilenv.approx_for_global compilation_unit with
+    | None -> A.value_unresolved (Symbol sym)
+    | Some export_info ->
+      match Symbol.Map.find sym export_info.symbol_id with
+      | approx -> A.augment_with_symbol (import_ex approx) sym
+      | exception Not_found ->
+        Misc.fatal_errorf
+          "Compilation unit = %a Cannot find symbol %a"
+          Compilation_unit.print compilation_unit
+          Symbol.print sym
+  end
+
+(* 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)
diff --git a/middle_end/flambda/import_approx.mli b/middle_end/flambda/import_approx.mli
new file mode 100644
index 0000000000..23d9d29482
--- /dev/null
+++ b/middle_end/flambda/import_approx.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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+(** 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
diff --git a/middle_end/inconstant_idents.ml b/middle_end/flambda/inconstant_idents.ml
index 59f8aa8a8c..59f8aa8a8c 100644
--- a/middle_end/inconstant_idents.ml
+++ b/middle_end/flambda/inconstant_idents.ml
diff --git a/middle_end/inconstant_idents.mli b/middle_end/flambda/inconstant_idents.mli
index 2c5309e022..2c5309e022 100644
--- a/middle_end/inconstant_idents.mli
+++ b/middle_end/flambda/inconstant_idents.mli
diff --git a/middle_end/initialize_symbol_to_let_symbol.ml b/middle_end/flambda/initialize_symbol_to_let_symbol.ml
index 31246b0d46..31246b0d46 100644
--- a/middle_end/initialize_symbol_to_let_symbol.ml
+++ b/middle_end/flambda/initialize_symbol_to_let_symbol.ml
diff --git a/middle_end/initialize_symbol_to_let_symbol.mli b/middle_end/flambda/initialize_symbol_to_let_symbol.mli
index fc54f76075..fc54f76075 100644
--- a/middle_end/initialize_symbol_to_let_symbol.mli
+++ b/middle_end/flambda/initialize_symbol_to_let_symbol.mli
diff --git a/middle_end/inline_and_simplify.ml b/middle_end/flambda/inline_and_simplify.ml
index 7d304cd88f..7d304cd88f 100644
--- a/middle_end/inline_and_simplify.ml
+++ b/middle_end/flambda/inline_and_simplify.ml
diff --git a/middle_end/inline_and_simplify.mli b/middle_end/flambda/inline_and_simplify.mli
index 9a8e6e8b46..9a8e6e8b46 100644
--- a/middle_end/inline_and_simplify.mli
+++ b/middle_end/flambda/inline_and_simplify.mli
diff --git a/middle_end/inline_and_simplify_aux.ml b/middle_end/flambda/inline_and_simplify_aux.ml
index bb725e8c64..bb725e8c64 100644
--- a/middle_end/inline_and_simplify_aux.ml
+++ b/middle_end/flambda/inline_and_simplify_aux.ml
diff --git a/middle_end/inline_and_simplify_aux.mli b/middle_end/flambda/inline_and_simplify_aux.mli
index 79d84a31b8..79d84a31b8 100644
--- a/middle_end/inline_and_simplify_aux.mli
+++ b/middle_end/flambda/inline_and_simplify_aux.mli
diff --git a/middle_end/inlining_cost.ml b/middle_end/flambda/inlining_cost.ml
index 33e870f90a..33e870f90a 100644
--- a/middle_end/inlining_cost.ml
+++ b/middle_end/flambda/inlining_cost.ml
diff --git a/middle_end/inlining_cost.mli b/middle_end/flambda/inlining_cost.mli
index 345f67abad..345f67abad 100644
--- a/middle_end/inlining_cost.mli
+++ b/middle_end/flambda/inlining_cost.mli
diff --git a/middle_end/inlining_decision.ml b/middle_end/flambda/inlining_decision.ml
index ca462a5613..ca462a5613 100644
--- a/middle_end/inlining_decision.ml
+++ b/middle_end/flambda/inlining_decision.ml
diff --git a/middle_end/inlining_decision.mli b/middle_end/flambda/inlining_decision.mli
index 3694e30366..3694e30366 100644
--- a/middle_end/inlining_decision.mli
+++ b/middle_end/flambda/inlining_decision.mli
diff --git a/middle_end/inlining_decision_intf.mli b/middle_end/flambda/inlining_decision_intf.mli
index 15a080316c..15a080316c 100644
--- a/middle_end/inlining_decision_intf.mli
+++ b/middle_end/flambda/inlining_decision_intf.mli
diff --git a/middle_end/inlining_stats.ml b/middle_end/flambda/inlining_stats.ml
index 6809d4cbb4..6809d4cbb4 100644
--- a/middle_end/inlining_stats.ml
+++ b/middle_end/flambda/inlining_stats.ml
diff --git a/middle_end/inlining_stats.mli b/middle_end/flambda/inlining_stats.mli
index f1e84fdcea..f1e84fdcea 100644
--- a/middle_end/inlining_stats.mli
+++ b/middle_end/flambda/inlining_stats.mli
diff --git a/middle_end/inlining_stats_types.ml b/middle_end/flambda/inlining_stats_types.ml
index 7aef0796d9..7aef0796d9 100644
--- a/middle_end/inlining_stats_types.ml
+++ b/middle_end/flambda/inlining_stats_types.ml
diff --git a/middle_end/inlining_stats_types.mli b/middle_end/flambda/inlining_stats_types.mli
index 9d476c8981..9d476c8981 100644
--- a/middle_end/inlining_stats_types.mli
+++ b/middle_end/flambda/inlining_stats_types.mli
diff --git a/middle_end/inlining_transforms.ml b/middle_end/flambda/inlining_transforms.ml
index b08e62bb0a..b08e62bb0a 100644
--- a/middle_end/inlining_transforms.ml
+++ b/middle_end/flambda/inlining_transforms.ml
diff --git a/middle_end/inlining_transforms.mli b/middle_end/flambda/inlining_transforms.mli
index e31d1b0849..e31d1b0849 100644
--- a/middle_end/inlining_transforms.mli
+++ b/middle_end/flambda/inlining_transforms.mli
diff --git a/middle_end/invariant_params.ml b/middle_end/flambda/invariant_params.ml
index a43cfdace1..a43cfdace1 100644
--- a/middle_end/invariant_params.ml
+++ b/middle_end/flambda/invariant_params.ml
diff --git a/middle_end/invariant_params.mli b/middle_end/flambda/invariant_params.mli
index c68514203c..c68514203c 100644
--- a/middle_end/invariant_params.mli
+++ b/middle_end/flambda/invariant_params.mli
diff --git a/middle_end/lift_code.ml b/middle_end/flambda/lift_code.ml
index 02292c46e1..02292c46e1 100644
--- a/middle_end/lift_code.ml
+++ b/middle_end/flambda/lift_code.ml
diff --git a/middle_end/lift_code.mli b/middle_end/flambda/lift_code.mli
index 92ecda0154..92ecda0154 100644
--- a/middle_end/lift_code.mli
+++ b/middle_end/flambda/lift_code.mli
diff --git a/middle_end/lift_constants.ml b/middle_end/flambda/lift_constants.ml
index dd60de9ce2..dd60de9ce2 100644
--- a/middle_end/lift_constants.ml
+++ b/middle_end/flambda/lift_constants.ml
diff --git a/middle_end/lift_constants.mli b/middle_end/flambda/lift_constants.mli
index 969c365e33..969c365e33 100644
--- a/middle_end/lift_constants.mli
+++ b/middle_end/flambda/lift_constants.mli
diff --git a/middle_end/lift_let_to_initialize_symbol.ml b/middle_end/flambda/lift_let_to_initialize_symbol.ml
index ccef0d8a1f..ccef0d8a1f 100644
--- a/middle_end/lift_let_to_initialize_symbol.ml
+++ b/middle_end/flambda/lift_let_to_initialize_symbol.ml
diff --git a/middle_end/lift_let_to_initialize_symbol.mli b/middle_end/flambda/lift_let_to_initialize_symbol.mli
index afb1c60f9c..afb1c60f9c 100644
--- a/middle_end/lift_let_to_initialize_symbol.mli
+++ b/middle_end/flambda/lift_let_to_initialize_symbol.mli
diff --git a/middle_end/parameter.ml b/middle_end/flambda/parameter.ml
index 0c916dd7ae..0c916dd7ae 100644
--- a/middle_end/parameter.ml
+++ b/middle_end/flambda/parameter.ml
diff --git a/middle_end/parameter.mli b/middle_end/flambda/parameter.mli
index ceed16786b..ceed16786b 100644
--- a/middle_end/parameter.mli
+++ b/middle_end/flambda/parameter.mli
diff --git a/middle_end/pass_wrapper.ml b/middle_end/flambda/pass_wrapper.ml
index a20053326f..a20053326f 100644
--- a/middle_end/pass_wrapper.ml
+++ b/middle_end/flambda/pass_wrapper.ml
diff --git a/middle_end/pass_wrapper.mli b/middle_end/flambda/pass_wrapper.mli
index 3a30e61d6d..3a30e61d6d 100644
--- a/middle_end/pass_wrapper.mli
+++ b/middle_end/flambda/pass_wrapper.mli
diff --git a/middle_end/projection.ml b/middle_end/flambda/projection.ml
index 2c660a2a28..2c660a2a28 100644
--- a/middle_end/projection.ml
+++ b/middle_end/flambda/projection.ml
diff --git a/middle_end/projection.mli b/middle_end/flambda/projection.mli
index 1b251ca262..1b251ca262 100644
--- a/middle_end/projection.mli
+++ b/middle_end/flambda/projection.mli
diff --git a/middle_end/ref_to_variables.ml b/middle_end/flambda/ref_to_variables.ml
index f93948f912..f93948f912 100644
--- a/middle_end/ref_to_variables.ml
+++ b/middle_end/flambda/ref_to_variables.ml
diff --git a/middle_end/ref_to_variables.mli b/middle_end/flambda/ref_to_variables.mli
index 38d3688917..38d3688917 100644
--- a/middle_end/ref_to_variables.mli
+++ b/middle_end/flambda/ref_to_variables.mli
diff --git a/middle_end/remove_free_vars_equal_to_args.ml b/middle_end/flambda/remove_free_vars_equal_to_args.ml
index 6327d30cda..6327d30cda 100644
--- a/middle_end/remove_free_vars_equal_to_args.ml
+++ b/middle_end/flambda/remove_free_vars_equal_to_args.ml
diff --git a/middle_end/remove_free_vars_equal_to_args.mli b/middle_end/flambda/remove_free_vars_equal_to_args.mli
index 49f25ac106..49f25ac106 100644
--- a/middle_end/remove_free_vars_equal_to_args.mli
+++ b/middle_end/flambda/remove_free_vars_equal_to_args.mli
diff --git a/middle_end/remove_unused_arguments.ml b/middle_end/flambda/remove_unused_arguments.ml
index f70da729ae..f70da729ae 100644
--- a/middle_end/remove_unused_arguments.ml
+++ b/middle_end/flambda/remove_unused_arguments.ml
diff --git a/middle_end/remove_unused_arguments.mli b/middle_end/flambda/remove_unused_arguments.mli
index 759b32f2d2..759b32f2d2 100644
--- a/middle_end/remove_unused_arguments.mli
+++ b/middle_end/flambda/remove_unused_arguments.mli
diff --git a/middle_end/remove_unused_closure_vars.ml b/middle_end/flambda/remove_unused_closure_vars.ml
index 0d4ad621dd..0d4ad621dd 100644
--- a/middle_end/remove_unused_closure_vars.ml
+++ b/middle_end/flambda/remove_unused_closure_vars.ml
diff --git a/middle_end/remove_unused_closure_vars.mli b/middle_end/flambda/remove_unused_closure_vars.mli
index 225697a814..225697a814 100644
--- a/middle_end/remove_unused_closure_vars.mli
+++ b/middle_end/flambda/remove_unused_closure_vars.mli
diff --git a/middle_end/remove_unused_program_constructs.ml b/middle_end/flambda/remove_unused_program_constructs.ml
index 059d68bcba..059d68bcba 100644
--- a/middle_end/remove_unused_program_constructs.ml
+++ b/middle_end/flambda/remove_unused_program_constructs.ml
diff --git a/middle_end/remove_unused_program_constructs.mli b/middle_end/flambda/remove_unused_program_constructs.mli
index 3a722011bb..3a722011bb 100644
--- a/middle_end/remove_unused_program_constructs.mli
+++ b/middle_end/flambda/remove_unused_program_constructs.mli
diff --git a/middle_end/share_constants.ml b/middle_end/flambda/share_constants.ml
index 2bbd7134b8..2bbd7134b8 100644
--- a/middle_end/share_constants.ml
+++ b/middle_end/flambda/share_constants.ml
diff --git a/middle_end/share_constants.mli b/middle_end/flambda/share_constants.mli
index 7fec22bc44..7fec22bc44 100644
--- a/middle_end/share_constants.mli
+++ b/middle_end/flambda/share_constants.mli
diff --git a/middle_end/simple_value_approx.ml b/middle_end/flambda/simple_value_approx.ml
index 34fc5ce056..34fc5ce056 100644
--- a/middle_end/simple_value_approx.ml
+++ b/middle_end/flambda/simple_value_approx.ml
diff --git a/middle_end/simple_value_approx.mli b/middle_end/flambda/simple_value_approx.mli
index dd38652f5b..dd38652f5b 100644
--- a/middle_end/simple_value_approx.mli
+++ b/middle_end/flambda/simple_value_approx.mli
diff --git a/middle_end/simplify_boxed_integer_ops.ml b/middle_end/flambda/simplify_boxed_integer_ops.ml
index 1f95a1ec2d..1f95a1ec2d 100644
--- a/middle_end/simplify_boxed_integer_ops.ml
+++ b/middle_end/flambda/simplify_boxed_integer_ops.ml
diff --git a/middle_end/simplify_boxed_integer_ops.mli b/middle_end/flambda/simplify_boxed_integer_ops.mli
index f3461043a1..f3461043a1 100644
--- a/middle_end/simplify_boxed_integer_ops.mli
+++ b/middle_end/flambda/simplify_boxed_integer_ops.mli
diff --git a/middle_end/simplify_boxed_integer_ops_intf.mli b/middle_end/flambda/simplify_boxed_integer_ops_intf.mli
index f30987ae11..f30987ae11 100644
--- a/middle_end/simplify_boxed_integer_ops_intf.mli
+++ b/middle_end/flambda/simplify_boxed_integer_ops_intf.mli
diff --git a/middle_end/simplify_common.ml b/middle_end/flambda/simplify_common.ml
index fcbbcfbcba..fcbbcfbcba 100644
--- a/middle_end/simplify_common.ml
+++ b/middle_end/flambda/simplify_common.ml
diff --git a/middle_end/simplify_common.mli b/middle_end/flambda/simplify_common.mli
index c667bfffe5..c667bfffe5 100644
--- a/middle_end/simplify_common.mli
+++ b/middle_end/flambda/simplify_common.mli
diff --git a/middle_end/simplify_primitives.ml b/middle_end/flambda/simplify_primitives.ml
index 349d2f40ba..349d2f40ba 100644
--- a/middle_end/simplify_primitives.ml
+++ b/middle_end/flambda/simplify_primitives.ml
diff --git a/middle_end/simplify_primitives.mli b/middle_end/flambda/simplify_primitives.mli
index a6b6330c03..a6b6330c03 100644
--- a/middle_end/simplify_primitives.mli
+++ b/middle_end/flambda/simplify_primitives.mli
diff --git a/middle_end/flambda/traverse_for_exported_symbols.ml b/middle_end/flambda/traverse_for_exported_symbols.ml
new file mode 100644
index 0000000000..1b7ce57f54
--- /dev/null
+++ b/middle_end/flambda/traverse_for_exported_symbols.ml
@@ -0,0 +1,267 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                     Fu Yong Quah, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2017 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+module A = Simple_value_approx
+
+type queue_elem =
+  | Q_symbol of Symbol.t
+  | Q_set_of_closures_id of Set_of_closures_id.t
+  | Q_export_id of Export_id.t
+
+type symbols_to_export =
+  { symbols                               : Symbol.Set.t;
+    export_ids                            : Export_id.Set.t;
+    set_of_closure_ids                    : Set_of_closures_id.Set.t;
+    set_of_closure_ids_keep_declaration   : Set_of_closures_id.Set.t;
+    relevant_imported_closure_ids         : Closure_id.Set.t;
+    relevant_local_closure_ids            : Closure_id.Set.t;
+    relevant_imported_vars_within_closure : Var_within_closure.Set.t;
+    relevant_local_vars_within_closure    : Var_within_closure.Set.t;
+  }
+
+let traverse
+      ~(sets_of_closures_map :
+          Flambda.set_of_closures Set_of_closures_id.Map.t)
+      ~(closure_id_to_set_of_closures_id :
+          Set_of_closures_id.t Closure_id.Map.t)
+      ~(function_declarations_map :
+          A.function_declarations Set_of_closures_id.Map.t)
+      ~(values : Export_info.descr Export_id.Map.t)
+      ~(symbol_id : Export_id.t Symbol.Map.t)
+      ~(root_symbol: Symbol.t) =
+  let relevant_set_of_closures_declaration_only =
+    ref Set_of_closures_id.Set.empty
+  in
+  let relevant_symbols = ref (Symbol.Set.singleton root_symbol) in
+  let relevant_set_of_closures = ref Set_of_closures_id.Set.empty in
+  let relevant_export_ids = ref Export_id.Set.empty in
+  let relevant_imported_closure_ids = ref Closure_id.Set.empty in
+  let relevant_local_closure_ids = ref Closure_id.Set.empty in
+  let relevant_imported_vars_within_closure =
+    ref Var_within_closure.Set.empty
+  in
+  let relevant_local_vars_with_closure = ref Var_within_closure.Set.empty in
+  let (queue : queue_elem Queue.t) = Queue.create () in
+  let conditionally_add_symbol symbol =
+    if not (Symbol.Set.mem symbol !relevant_symbols) then begin
+      relevant_symbols :=
+        Symbol.Set.add symbol !relevant_symbols;
+      Queue.add (Q_symbol symbol) queue
+    end
+  in
+  let conditionally_add_set_of_closures_id set_of_closures_id =
+    if not (Set_of_closures_id.Set.mem
+         set_of_closures_id !relevant_set_of_closures) then begin
+      relevant_set_of_closures :=
+        Set_of_closures_id.Set.add set_of_closures_id
+          !relevant_set_of_closures;
+      Queue.add (Q_set_of_closures_id set_of_closures_id) queue
+    end
+  in
+  let conditionally_add_export_id export_id =
+    if not (Export_id.Set.mem export_id !relevant_export_ids) then begin
+      relevant_export_ids :=
+        Export_id.Set.add export_id !relevant_export_ids;
+      Queue.add (Q_export_id export_id) queue
+    end
+  in
+  let process_approx (approx : Export_info.approx) =
+    match approx with
+    | Value_id export_id ->
+      conditionally_add_export_id export_id
+    | Value_symbol symbol ->
+      conditionally_add_symbol symbol
+    | Value_unknown -> ()
+  in
+  let process_value_set_of_closures
+        (soc : Export_info.value_set_of_closures) =
+    conditionally_add_set_of_closures_id soc.set_of_closures_id;
+    Var_within_closure.Map.iter
+      (fun _ value -> process_approx value) soc.bound_vars;
+    Closure_id.Map.iter
+      (fun _ value -> process_approx value) soc.results;
+    begin match soc.aliased_symbol with
+    | None -> ()
+    | Some symbol -> conditionally_add_symbol symbol
+    end
+  in
+  let process_function_body (function_body : A.function_body) =
+    Flambda_iterators.iter
+      (fun (term : Flambda.t) ->
+         match term with
+         | Flambda.Apply { kind ; _ } ->
+           begin match kind with
+           | Indirect -> ()
+           | Direct closure_id ->
+             begin match
+               Closure_id.Map.find
+                 closure_id
+                 closure_id_to_set_of_closures_id
+             with
+             | exception Not_found ->
+               relevant_imported_closure_ids :=
+                 Closure_id.Set.add closure_id
+                   !relevant_imported_closure_ids
+             | set_of_closures_id ->
+               relevant_local_closure_ids :=
+                 Closure_id.Set.add closure_id
+                   !relevant_local_closure_ids;
+               conditionally_add_set_of_closures_id
+                 set_of_closures_id
+             end
+           end
+         | _ -> ())
+      (fun (named : Flambda.named) ->
+         let process_closure_id closure_id =
+           match
+             Closure_id.Map.find closure_id closure_id_to_set_of_closures_id
+           with
+           | exception Not_found ->
+             relevant_imported_closure_ids :=
+               Closure_id.Set.add closure_id !relevant_imported_closure_ids
+           | set_of_closure_id ->
+             relevant_local_closure_ids :=
+               Closure_id.Set.add closure_id !relevant_local_closure_ids;
+             relevant_set_of_closures_declaration_only :=
+               Set_of_closures_id.Set.add
+                 set_of_closure_id
+                 !relevant_set_of_closures_declaration_only
+         in
+         match named with
+         | Symbol symbol
+         | Read_symbol_field (symbol, _) ->
+           conditionally_add_symbol symbol
+         | Set_of_closures soc ->
+           conditionally_add_set_of_closures_id
+             soc.function_decls.set_of_closures_id
+         | Project_closure { closure_id; _ } ->
+           process_closure_id closure_id
+         | Move_within_set_of_closures { start_from; move_to; _ } ->
+           process_closure_id start_from;
+           process_closure_id move_to
+         | Project_var { closure_id ; var; _ } ->
+           begin match
+             Closure_id.Map.find
+               closure_id closure_id_to_set_of_closures_id
+           with
+           | exception Not_found ->
+             relevant_imported_closure_ids :=
+               Closure_id.Set.add closure_id
+                 !relevant_imported_closure_ids;
+             relevant_imported_vars_within_closure :=
+               Var_within_closure.Set.add var
+                 !relevant_imported_vars_within_closure
+           | set_of_closure_id ->
+             relevant_local_closure_ids :=
+               Closure_id.Set.add closure_id
+                 !relevant_local_closure_ids;
+             relevant_local_vars_with_closure :=
+               Var_within_closure.Set.add var
+                 !relevant_local_vars_with_closure;
+             relevant_set_of_closures_declaration_only :=
+               Set_of_closures_id.Set.add
+                 set_of_closure_id
+                 !relevant_set_of_closures_declaration_only
+           end
+         | Prim _
+         | Expr _
+         | Const _
+         | Allocated_const _
+         | Read_mutable _ -> ())
+      function_body.body
+  in
+  let rec loop () =
+    if Queue.is_empty queue then
+      ()
+    else begin
+      begin match Queue.pop queue with
+      | Q_export_id export_id ->
+        begin match Export_id.Map.find export_id values with
+        | exception Not_found -> ()
+        | Value_block (_, approxes) ->
+          Array.iter process_approx approxes
+        | Value_closure value_closure ->
+          process_value_set_of_closures value_closure.set_of_closures
+        | Value_set_of_closures soc ->
+          process_value_set_of_closures soc
+        | _ -> ()
+        end
+      | Q_symbol symbol ->
+        let compilation_unit = Symbol.compilation_unit symbol in
+        if Compilation_unit.is_current compilation_unit then begin
+          match Symbol.Map.find symbol symbol_id with
+          | exception Not_found ->
+            Misc.fatal_errorf "cannot find symbol's export id %a\n"
+              Symbol.print symbol
+          | export_id ->
+            conditionally_add_export_id export_id
+        end
+      | Q_set_of_closures_id set_of_closures_id ->
+        begin match
+          Set_of_closures_id.Map.find
+            set_of_closures_id function_declarations_map
+        with
+        | exception Not_found -> ()
+        | function_declarations ->
+          Variable.Map.iter
+            (fun (_ : Variable.t) (fun_decl : A.function_declaration) ->
+               match fun_decl.function_body with
+               | None -> ()
+               | Some function_body -> process_function_body function_body)
+            function_declarations.funs
+        end
+      end;
+      loop ()
+    end
+  in
+  Queue.add (Q_symbol root_symbol) queue;
+  loop ();
+
+  Closure_id.Map.iter (fun closure_id set_of_closure_id ->
+      if Set_of_closures_id.Set.mem
+           set_of_closure_id !relevant_set_of_closures
+      then begin
+        relevant_local_closure_ids :=
+          Closure_id.Set.add closure_id !relevant_local_closure_ids
+      end)
+    closure_id_to_set_of_closures_id;
+
+  Set_of_closures_id.Set.iter (fun set_of_closures_id ->
+      match
+        Set_of_closures_id.Map.find set_of_closures_id sets_of_closures_map
+      with
+      | exception Not_found -> ()
+      | set_of_closures ->
+        Variable.Map.iter (fun var _ ->
+            relevant_local_vars_with_closure :=
+              Var_within_closure.Set.add
+                (Var_within_closure.wrap var)
+                !relevant_local_vars_with_closure)
+          set_of_closures.free_vars)
+    !relevant_set_of_closures;
+
+  { symbols                             = !relevant_symbols;
+    export_ids                          = !relevant_export_ids;
+    set_of_closure_ids                  = !relevant_set_of_closures;
+    set_of_closure_ids_keep_declaration =
+      !relevant_set_of_closures_declaration_only;
+    relevant_imported_closure_ids       = !relevant_imported_closure_ids;
+    relevant_local_closure_ids          = !relevant_local_closure_ids;
+    relevant_imported_vars_within_closure =
+      !relevant_imported_vars_within_closure;
+    relevant_local_vars_within_closure =
+      !relevant_local_vars_with_closure;
+  }
diff --git a/middle_end/flambda/traverse_for_exported_symbols.mli b/middle_end/flambda/traverse_for_exported_symbols.mli
new file mode 100644
index 0000000000..2825a38623
--- /dev/null
+++ b/middle_end/flambda/traverse_for_exported_symbols.mli
@@ -0,0 +1,41 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                     Fu Yong Quah, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2017 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+type symbols_to_export =
+  { symbols                               : Symbol.Set.t;
+    export_ids                            : Export_id.Set.t;
+    set_of_closure_ids                    : Set_of_closures_id.Set.t;
+    set_of_closure_ids_keep_declaration   : Set_of_closures_id.Set.t;
+    relevant_imported_closure_ids         : Closure_id.Set.t;
+    relevant_local_closure_ids            : Closure_id.Set.t;
+    relevant_imported_vars_within_closure : Var_within_closure.Set.t;
+    relevant_local_vars_within_closure    : Var_within_closure.Set.t;
+  }
+
+(** Computes the transitive closure in [Symbol.t], [Closure_id.t] and
+    [Set_of_closures_id.t] and determines which ones of those should be
+    exported (i.e: included in the cmx files).
+**)
+val traverse
+   : sets_of_closures_map: Flambda.set_of_closures Set_of_closures_id.Map.t
+  -> closure_id_to_set_of_closures_id:
+        Set_of_closures_id.t Closure_id.Map.t
+  -> function_declarations_map:
+        Simple_value_approx.function_declarations Set_of_closures_id.Map.t
+  -> values: Export_info.descr Export_id.Map.t
+  -> symbol_id: Export_id.t Symbol.Map.t
+  -> root_symbol: Symbol.t
+  -> symbols_to_export
diff --git a/middle_end/flambda/un_anf.ml b/middle_end/flambda/un_anf.ml
new file mode 100644
index 0000000000..50f9e7b1e2
--- /dev/null
+++ b/middle_end/flambda/un_anf.ml
@@ -0,0 +1,817 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-30-40-41-42"]
+
+(* CR-someday vlaviron for mshinwell: I believe that the phantom lets introduced
+   in un_anf (when the new debug_full flag is enabled) bind mostly variables
+   that were created in the middle-end. Is it relevant to generate debugging
+   information for such variables ? I expect later pull requests to refine the
+   generation of these phantom constructions anyway, but maybe it would already
+   make sense to restrict the phantom let generation to variables with an actual
+   provenance.
+*)
+
+module V = Backend_var
+module VP = Backend_var.With_provenance
+
+(* We say that an [V.t] is "linear" iff:
+   (a) it is used exactly once;
+   (b) it is never assigned to (using [Uassign]).
+*)
+type var_info =
+  { used : V.Set.t;
+    linear : V.Set.t;
+    assigned : V.Set.t;
+    closure_environment : V.Set.t;
+    let_bound_vars_that_can_be_moved : V.Set.t;
+  }
+
+let ignore_uconstant (_ : Clambda.uconstant) = ()
+let ignore_ulambda (_ : Clambda.ulambda) = ()
+let ignore_ulambda_list (_ : Clambda.ulambda list) = ()
+let ignore_uphantom_defining_expr_option
+      (_ : Clambda.uphantom_defining_expr option) = ()
+let ignore_function_label (_ : Clambda.function_label) = ()
+let ignore_debuginfo (_ : Debuginfo.t) = ()
+let ignore_int (_ : int) = ()
+let ignore_var (_ : V.t) = ()
+let ignore_var_option (_ : V.t option) = ()
+let ignore_primitive (_ : Clambda_primitives.primitive) = ()
+let ignore_string (_ : string) = ()
+let ignore_int_array (_ : int array) = ()
+let ignore_var_with_provenance (_ : VP.t) = ()
+let ignore_params_with_value_kind (_ : (VP.t * Lambda.value_kind) list) = ()
+let ignore_direction_flag (_ : Asttypes.direction_flag) = ()
+let ignore_meth_kind (_ : Lambda.meth_kind) = ()
+let ignore_value_kind (_ : Lambda.value_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_var (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 (VP.name env_var = "env");
+    Some env_var
+  else
+    (* closed function, no environment *)
+    None
+
+let make_var_info (clam : Clambda.ulambda) : var_info =
+  let t : int V.Tbl.t = V.Tbl.create 42 in
+  let assigned_vars = ref V.Set.empty in
+  let environment_vars = ref V.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 var ->
+      begin match V.Tbl.find t var with
+      | n -> V.Tbl.replace t var (n + 1)
+      | exception Not_found -> V.Tbl.add t var 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; return; body; dbg; env; } as clos) ->
+          (match closure_environment_var clos with
+           | None -> ()
+           | Some env_var ->
+             environment_vars :=
+               V.Set.add (VP.var env_var) !environment_vars);
+          ignore_function_label label;
+          ignore_int arity;
+          ignore_params_with_value_kind params;
+          ignore_value_kind return;
+          loop body;
+          ignore_debuginfo dbg;
+          ignore_var_option env)
+        functions
+    | Uoffset (expr, offset) ->
+      loop expr;
+      ignore_int offset
+    | Ulet (_let_kind, _value_kind, _var, def, body) ->
+      loop def;
+      loop body
+    | Uphantom_let (var, defining_expr_opt, body) ->
+      ignore_var_with_provenance var;
+      ignore_uphantom_defining_expr_option defining_expr_opt;
+      loop body
+    | Uletrec (defs, body) ->
+      List.iter (fun (var, def) ->
+          ignore_var_with_provenance var;
+          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 }, dbg) ->
+      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;
+      ignore_debuginfo dbg
+    | 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, vars, body, handler) ->
+      ignore_int static_exn;
+      ignore_params_with_value_kind vars;
+      loop body;
+      loop handler
+    | Utrywith (body, var, handler) ->
+      loop body;
+      ignore_var_with_provenance var;
+      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 (var, low, high, direction_flag, body) ->
+      ignore_var_with_provenance var;
+      loop low;
+      loop high;
+      ignore_direction_flag direction_flag;
+      loop body
+    | Uassign (var, expr) ->
+      assigned_vars := V.Set.add var !assigned_vars;
+      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 =
+    V.Tbl.fold (fun var n acc ->
+        assert (n >= 1);
+        if n = 1 && not (V.Set.mem var !assigned_vars)
+        then V.Set.add var acc
+        else acc)
+      t V.Set.empty
+  in
+  let assigned = !assigned_vars 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]. *)
+    V.Tbl.fold (fun var _n acc -> V.Set.add var acc)
+      t assigned
+  in
+  { used; linear; assigned; closure_environment = !environment_vars;
+    let_bound_vars_that_can_be_moved = V.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 var_info (clam : Clambda.ulambda) =
+  let obviously_constant = ref V.Set.empty in
+  let can_move = ref V.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 V.Set.mem arg !obviously_constant ->
+        loop let_bound_vars args
+      | let_bound_var::let_bound_vars, (Uvar arg)::args
+          when V.same let_bound_var arg
+            && not (V.Set.mem arg var_info.assigned) ->
+        assert (V.Set.mem arg var_info.used);
+        assert (V.Set.mem arg var_info.linear);
+        can_move := V.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 var ->
+      if V.Set.mem var var_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; return; body; dbg; env} ->
+          ignore_function_label label;
+          ignore_int arity;
+          ignore_params_with_value_kind params;
+          ignore_value_kind return;
+          let_stack := [];
+          loop body;
+          let_stack := [];
+          ignore_debuginfo dbg;
+          ignore_var_option env)
+        functions
+    | Uoffset (expr, offset) ->
+      (* [expr] should usually be a variable. *)
+      examine_argument_list [expr];
+      ignore_int offset
+    | Ulet (_let_kind, _value_kind, var, def, body) ->
+      let var = VP.var var in
+      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 := V.Set.add var !obviously_constant;
+        loop body
+      | _ ->
+        loop def;
+        if V.Set.mem var var_info.linear then begin
+          let_stack := var::!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
+    | Uphantom_let (var, _defining_expr, body) ->
+      ignore_var_with_provenance var;
+      loop body
+    | 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 (var, def) ->
+          ignore_var_with_provenance var;
+          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 }, dbg) ->
+      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;
+      ignore_debuginfo dbg;
+      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;
+      examine_argument_list args
+    | Ucatch (static_exn, vars, body, handler) ->
+      ignore_int static_exn;
+      ignore_params_with_value_kind vars;
+      let_stack := [];
+      loop body;
+      let_stack := [];
+      loop handler;
+      let_stack := []
+    | Utrywith (body, var, handler) ->
+      let_stack := [];
+      loop body;
+      let_stack := [];
+      ignore_var_with_provenance var;
+      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 (var, low, high, direction_flag, body) ->
+      ignore_var_with_provenance var;
+      (* 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 (var, expr) ->
+      ignore_var var;
+      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 var ->
+    if not (V.Set.mem var is_let_moveable) then
+      clam
+    else
+      begin match V.Map.find var env with
+      | clam -> clam
+      | exception Not_found ->
+        Misc.fatal_errorf "substitute_let_moveable: Unbound variable %a"
+          V.print var
+      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 (let_kind, value_kind, var, def, body) ->
+    let def = substitute_let_moveable is_let_moveable env def in
+    if V.Set.mem (VP.var var) is_let_moveable then
+      let env = V.Map.add (VP.var var) def env in
+      let body = substitute_let_moveable is_let_moveable env body in
+      (* If we are about to delete a [let] in debug mode, keep it for the
+         debugger. *)
+      (* CR-someday mshinwell: find out why some closure constructions were
+         not leaving phantom lets behind after substitution. *)
+      if not !Clflags.debug_full then
+        body
+      else
+        match def with
+        | Uconst const ->
+          Uphantom_let (var, Some (Clambda.Uphantom_const const), body)
+        | Uvar alias_of ->
+          Uphantom_let (var, Some (Clambda.Uphantom_var alias_of), body)
+        | _ ->
+          Uphantom_let (var, None, body)
+    else
+      Ulet (let_kind, value_kind,
+            var, def, substitute_let_moveable is_let_moveable env body)
+  | Uphantom_let (var, defining_expr, body) ->
+    let body = substitute_let_moveable is_let_moveable env body in
+    Uphantom_let (var, defining_expr, body)
+  | Uletrec (defs, body) ->
+    let defs =
+      List.map (fun (var, def) ->
+          var, 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, dbg) ->
+    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, dbg)
+  | 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, vars, 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, vars, body, handler)
+  | Utrywith (body, var, 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, var, 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 (var, 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 (var, low, high, direction, body)
+  | Uassign (var, expr) ->
+    let expr = substitute_let_moveable is_let_moveable env expr in
+    Uassign (var, 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 | Constant | Moveable
+
+let both_moveable a b =
+  match a, b with
+  | Constant, Constant -> Constant
+  | Constant, Moveable
+  | Moveable, Constant
+  | Moveable, Moveable -> Moveable
+  | Constant, Fixed
+  | Moveable, Fixed
+  | Fixed, Constant
+  | Fixed, Moveable
+  | Fixed, Fixed -> Fixed
+
+let primitive_moveable (prim : Clambda_primitives.primitive)
+    (args : Clambda.ulambda list)
+    (var_info : var_info) =
+  match prim, args with
+  | Pfield _, [Uconst (Uconst_ref (_, _))] ->
+    (* CR-someday 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 var] when V.Set.mem var var_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 = Constant | Moveable
+
+(** Eliminate, through substitution, [let]-bindings of linear variables with
+    moveable defining expressions. *)
+let rec un_anf_and_moveable var_info env (clam : Clambda.ulambda)
+      : Clambda.ulambda * moveable =
+  match clam with
+  | Uvar var ->
+    begin match V.Map.find var env with
+    | Constant, def -> def, Constant
+    | Moveable, def -> def, Moveable
+    | exception Not_found ->
+      let moveable : moveable =
+        if V.Set.mem var var_info.assigned then
+          Fixed
+        else
+          Moveable
+      in
+      clam, moveable
+    end
+  | Uconst _ ->
+    (* Constant closures are rewritten separately. *)
+    clam, Constant
+  | Udirect_apply (label, args, dbg) ->
+    let args = un_anf_list var_info env args in
+    Udirect_apply (label, args, dbg), Fixed
+  | Ugeneric_apply (func, args, dbg) ->
+    let func = un_anf var_info env func in
+    let args = un_anf_list var_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 var_info env ufunction.body;
+          })
+        functions
+    in
+    let variables_bound_by_the_closure =
+      un_anf_list var_info env variables_bound_by_the_closure
+    in
+    Uclosure (functions, variables_bound_by_the_closure), Fixed
+  | Uoffset (clam, n) ->
+    let clam, moveable = un_anf_and_moveable var_info env clam in
+    Uoffset (clam, n), both_moveable Moveable moveable
+  | Ulet (_let_kind, _value_kind, var, def, Uvar var')
+      when V.same (VP.var var) var' ->
+    un_anf_and_moveable var_info env def
+  | Ulet (let_kind, value_kind, var, def, body) ->
+    let def, def_moveable = un_anf_and_moveable var_info env def in
+    let is_linear = V.Set.mem (VP.var var) var_info.linear in
+    let is_used = V.Set.mem (VP.var var) var_info.used in
+    let is_assigned = V.Set.mem (VP.var var) var_info.assigned in
+    let maybe_for_debugger (body, moveable) : Clambda.ulambda * moveable =
+      if not !Clflags.debug_full then
+        body, moveable
+      else
+        match def with
+        | Uconst const ->
+          Uphantom_let (var, Some (Clambda.Uphantom_const const),
+            body), moveable
+        | Uvar alias_of ->
+          Uphantom_let (var, Some (Clambda.Uphantom_var alias_of), body),
+            moveable
+        | _ ->
+          Uphantom_let (var, None, body), moveable
+    in
+    begin match def_moveable, is_linear, is_used, is_assigned with
+    | (Constant | Moveable), _, false, _ ->
+      (* A moveable expression that is never used may be eliminated.
+         However, if in debug mode and the defining expression is
+         appropriate, keep the let (as a phantom let) for the debugger. *)
+      maybe_for_debugger (un_anf_and_moveable var_info env body)
+    | Constant, _, true, false
+    (* A constant expression bound to an unassigned variable can replace any
+       occurrences of the variable.  The same comment as above concerning
+       phantom lets applies. *)
+    | Moveable, true, true, false  ->
+      (* A moveable expression bound to a linear unassigned [V.t]
+         may replace the single occurrence of the variable.  The same comment
+         as above concerning phantom lets applies. *)
+      let def_moveable =
+        match def_moveable with
+        | Moveable -> Moveable
+        | Constant -> Constant
+        | Fixed -> assert false
+      in
+      let env = V.Map.add (VP.var var) (def_moveable, def) env in
+      maybe_for_debugger (un_anf_and_moveable var_info env body)
+    | (Constant | Moveable), _, _, true
+        (* Constant or Moveable but assigned. *)
+    | Moveable, false, _, _
+        (* Moveable but not used linearly. *)
+    | Fixed, _, _, _ ->
+      let body, body_moveable = un_anf_and_moveable var_info env body in
+      Ulet (let_kind, value_kind, var, def, body),
+      both_moveable def_moveable body_moveable
+    end
+  | Uphantom_let (var, defining_expr, body) ->
+    let body, body_moveable = un_anf_and_moveable var_info env body in
+    Uphantom_let (var, defining_expr, body), body_moveable
+  | Uletrec (defs, body) ->
+    let defs =
+      List.map (fun (var, def) -> var, un_anf var_info env def) defs
+    in
+    let body = un_anf var_info env body in
+    Uletrec (defs, body), Fixed
+  | Uprim (prim, args, dbg) ->
+    let args, args_moveable = un_anf_list_and_moveable var_info env args in
+    let moveable =
+      both_moveable args_moveable (primitive_moveable prim args var_info)
+    in
+    Uprim (prim, args, dbg), moveable
+  | Uswitch (cond, sw, dbg) ->
+    let cond = un_anf var_info env cond in
+    let sw =
+      { sw with
+        us_actions_consts = un_anf_array var_info env sw.us_actions_consts;
+        us_actions_blocks = un_anf_array var_info env sw.us_actions_blocks;
+      }
+    in
+    Uswitch (cond, sw, dbg), Fixed
+  | Ustringswitch (cond, branches, default) ->
+    let cond = un_anf var_info env cond in
+    let branches =
+      List.map (fun (s, branch) -> s, un_anf var_info env branch)
+        branches
+    in
+    let default = Misc.may_map (un_anf var_info env) default in
+    Ustringswitch (cond, branches, default), Fixed
+  | Ustaticfail (n, args) ->
+    let args = un_anf_list var_info env args in
+    Ustaticfail (n, args), Fixed
+  | Ucatch (n, vars, body, handler) ->
+    let body = un_anf var_info env body in
+    let handler = un_anf var_info env handler in
+    Ucatch (n, vars, body, handler), Fixed
+  | Utrywith (body, var, handler) ->
+    let body = un_anf var_info env body in
+    let handler = un_anf var_info env handler in
+    Utrywith (body, var, handler), Fixed
+  | Uifthenelse (cond, ifso, ifnot) ->
+    let cond, cond_moveable = un_anf_and_moveable var_info env cond in
+    let ifso, ifso_moveable = un_anf_and_moveable var_info env ifso in
+    let ifnot, ifnot_moveable = un_anf_and_moveable var_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 var_info env e1 in
+    let e2 = un_anf var_info env e2 in
+    Usequence (e1, e2), Fixed
+  | Uwhile (cond, body) ->
+    let cond = un_anf var_info env cond in
+    let body = un_anf var_info env body in
+    Uwhile (cond, body), Fixed
+  | Ufor (var, low, high, direction, body) ->
+    let low = un_anf var_info env low in
+    let high = un_anf var_info env high in
+    let body = un_anf var_info env body in
+    Ufor (var, low, high, direction, body), Fixed
+  | Uassign (var, expr) ->
+    let expr = un_anf var_info env expr in
+    Uassign (var, expr), Fixed
+  | Usend (kind, e1, e2, args, dbg) ->
+    let e1 = un_anf var_info env e1 in
+    let e2 = un_anf var_info env e2 in
+    let args = un_anf_list var_info env args in
+    Usend (kind, e1, e2, args, dbg), Fixed
+  | Uunreachable ->
+    Uunreachable, Fixed
+
+and un_anf var_info env clam : Clambda.ulambda =
+  let clam, _moveable = un_anf_and_moveable var_info env clam in
+  clam
+
+and un_anf_list_and_moveable var_info env clams
+      : Clambda.ulambda list * moveable =
+  List.fold_right (fun clam (l, acc_moveable) ->
+      let clam, moveable = un_anf_and_moveable var_info env clam in
+      clam :: l, both_moveable moveable acc_moveable)
+    clams ([], (Moveable : moveable))
+
+and un_anf_list var_info env clams : Clambda.ulambda list =
+  let clams, _moveable = un_anf_list_and_moveable var_info env clams in
+  clams
+
+and un_anf_array var_info env clams : Clambda.ulambda array =
+  Array.map (un_anf var_info env) clams
+
+let apply ~ppf_dump clam ~what =
+  let var_info = make_var_info clam in
+  let let_bound_vars_that_can_be_moved =
+    let_bound_vars_that_can_be_moved var_info clam
+  in
+  let clam =
+    substitute_let_moveable let_bound_vars_that_can_be_moved
+      V.Map.empty clam
+  in
+  let var_info = make_var_info clam in
+  let clam = un_anf var_info V.Map.empty clam in
+  if !Clflags.dump_clambda then begin
+    Format.fprintf ppf_dump
+      "@.un-anf (%s):@ %a@." what Printclambda.clambda clam
+  end;
+  clam
diff --git a/middle_end/flambda/un_anf.mli b/middle_end/flambda/un_anf.mli
new file mode 100644
index 0000000000..92ea06cd03
--- /dev/null
+++ b/middle_end/flambda/un_anf.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 Lesser 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
+  : ppf_dump:Format.formatter
+  -> Clambda.ulambda
+  -> what:string
+  -> Clambda.ulambda
diff --git a/middle_end/unbox_closures.ml b/middle_end/flambda/unbox_closures.ml
index 5c86bed3da..5c86bed3da 100644
--- a/middle_end/unbox_closures.ml
+++ b/middle_end/flambda/unbox_closures.ml
diff --git a/middle_end/unbox_closures.mli b/middle_end/flambda/unbox_closures.mli
index fb935a622b..fb935a622b 100644
--- a/middle_end/unbox_closures.mli
+++ b/middle_end/flambda/unbox_closures.mli
diff --git a/middle_end/unbox_free_vars_of_closures.ml b/middle_end/flambda/unbox_free_vars_of_closures.ml
index 7a4e48ed44..7a4e48ed44 100644
--- a/middle_end/unbox_free_vars_of_closures.ml
+++ b/middle_end/flambda/unbox_free_vars_of_closures.ml
diff --git a/middle_end/unbox_free_vars_of_closures.mli b/middle_end/flambda/unbox_free_vars_of_closures.mli
index 3ee181ee3c..3ee181ee3c 100644
--- a/middle_end/unbox_free_vars_of_closures.mli
+++ b/middle_end/flambda/unbox_free_vars_of_closures.mli
diff --git a/middle_end/unbox_specialised_args.ml b/middle_end/flambda/unbox_specialised_args.ml
index 70eb87601a..70eb87601a 100644
--- a/middle_end/unbox_specialised_args.ml
+++ b/middle_end/flambda/unbox_specialised_args.ml
diff --git a/middle_end/unbox_specialised_args.mli b/middle_end/flambda/unbox_specialised_args.mli
index f019176482..f019176482 100644
--- a/middle_end/unbox_specialised_args.mli
+++ b/middle_end/flambda/unbox_specialised_args.mli
diff --git a/middle_end/int_replace_polymorphic_compare.ml b/middle_end/int_replace_polymorphic_compare.ml
deleted file mode 100644
index 7cd6bf1099..0000000000
--- a/middle_end/int_replace_polymorphic_compare.ml
+++ /dev/null
@@ -1,8 +0,0 @@
-let ( = )   : int -> int -> bool = Stdlib.( = )
-let ( <> )  : int -> int -> bool = Stdlib.( <> )
-let ( < )   : int -> int -> bool = Stdlib.( < )
-let ( > )   : int -> int -> bool = Stdlib.( > )
-let ( <= )  : int -> int -> bool = Stdlib.( <= )
-let ( >= )  : int -> int -> bool = Stdlib.( >= )
-
-let compare : int -> int -> int  = Stdlib.compare
diff --git a/middle_end/int_replace_polymorphic_compare.mli b/middle_end/int_replace_polymorphic_compare.mli
deleted file mode 100644
index 689e741b66..0000000000
--- a/middle_end/int_replace_polymorphic_compare.mli
+++ /dev/null
@@ -1,8 +0,0 @@
-val ( = )   : int -> int -> bool
-val ( <> )  : int -> int -> bool
-val ( < )   : int -> int -> bool
-val ( > )   : int -> int -> bool
-val ( <= )  : int -> int -> bool
-val ( >= )  : int -> int -> bool
-
-val compare : int -> int -> int
diff --git a/middle_end/base_types/linkage_name.ml b/middle_end/linkage_name.ml
index 46febfba8f..46febfba8f 100644
--- a/middle_end/base_types/linkage_name.ml
+++ b/middle_end/linkage_name.ml
diff --git a/middle_end/base_types/linkage_name.mli b/middle_end/linkage_name.mli
index 58731917cd..58731917cd 100644
--- a/middle_end/base_types/linkage_name.mli
+++ b/middle_end/linkage_name.mli
diff --git a/middle_end/printclambda.ml b/middle_end/printclambda.ml
new file mode 100644
index 0000000000..fceb34851d
--- /dev/null
+++ b/middle_end/printclambda.ml
@@ -0,0 +1,272 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+open Format
+open Asttypes
+open Clambda
+
+module V = Backend_var
+module VP = Backend_var.With_provenance
+
+let mutable_flag = function
+  | Mutable-> "[mut]"
+  | Immutable -> ""
+
+let value_kind =
+  let open Lambda in
+  function
+  | Pgenval -> ""
+  | Pintval -> ":int"
+  | Pfloatval -> ":float"
+  | Pboxedintval Pnativeint -> ":nativeint"
+  | Pboxedintval Pint32 -> ":int32"
+  | Pboxedintval Pint64 -> ":int64"
+
+let rec structured_constant ppf = function
+  | Uconst_float x -> fprintf ppf "%F" x
+  | Uconst_int32 x -> fprintf ppf "%ldl" x
+  | Uconst_int64 x -> fprintf ppf "%LdL" x
+  | Uconst_nativeint x -> fprintf ppf "%ndn" x
+  | Uconst_block (tag, l) ->
+      fprintf ppf "block(%i" tag;
+      List.iter (fun u -> fprintf ppf ",%a" uconstant u) l;
+      fprintf ppf ")"
+  | Uconst_float_array [] ->
+      fprintf ppf "floatarray()"
+  | Uconst_float_array (f1 :: fl) ->
+      fprintf ppf "floatarray(%F" f1;
+      List.iter (fun f -> fprintf ppf ",%F" f) fl;
+      fprintf ppf ")"
+  | Uconst_string s -> fprintf ppf "%S" s
+  | Uconst_closure(clos, sym, fv) ->
+      let funs ppf =
+        List.iter (fprintf ppf "@ %a" one_fun) in
+      let sconsts ppf scl =
+        List.iter (fun sc -> fprintf ppf "@ %a" uconstant sc) scl in
+      fprintf ppf "@[<2>(const_closure%a %s@ %a)@]" funs clos sym sconsts fv
+
+and one_fun ppf f =
+  let idents ppf =
+    List.iter
+      (fun (x, k) ->
+         fprintf ppf "@ %a%a"
+           VP.print x
+           Printlambda.value_kind k
+      )
+  in
+  fprintf ppf "(fun@ %s%s@ %d@ @[<2>%a@]@ @[<2>%a@])"
+    f.label (value_kind f.return) f.arity idents f.params lam f.body
+
+and phantom_defining_expr ppf = function
+  | Uphantom_const const -> uconstant ppf const
+  | Uphantom_var var -> Ident.print ppf var
+  | Uphantom_offset_var { var; offset_in_words; } ->
+    Format.fprintf ppf "%a+(%d)" Backend_var.print var offset_in_words
+  | Uphantom_read_field { var; field; } ->
+    Format.fprintf ppf "%a[%d]" Backend_var.print var field
+  | Uphantom_read_symbol_field { sym; field; } ->
+    Format.fprintf ppf "%s[%d]" sym field
+  | Uphantom_block { tag; fields; } ->
+    Format.fprintf ppf "[%d: " tag;
+    List.iter (fun field ->
+        Format.fprintf ppf "%a; " Backend_var.print field)
+      fields;
+    Format.fprintf ppf "]"
+
+and phantom_defining_expr_opt ppf = function
+  | None -> Format.fprintf ppf "DEAD"
+  | Some expr -> phantom_defining_expr ppf expr
+
+and uconstant ppf = function
+  | Uconst_ref (s, Some c) ->
+      fprintf ppf "%S=%a" s structured_constant c
+  | Uconst_ref (s, None) -> fprintf ppf "%S"s
+  | Uconst_int i -> fprintf ppf "%i" i
+  | Uconst_ptr i -> fprintf ppf "%ia" i
+
+and lam ppf = function
+  | Uvar id ->
+      V.print ppf id
+  | Uconst c -> uconstant ppf c
+  | Udirect_apply(f, largs, _) ->
+      let lams ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(apply*@ %s %a)@]" f lams largs
+  | Ugeneric_apply(lfun, largs, _) ->
+      let lams ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(apply@ %a%a)@]" lam lfun lams largs
+  | Uclosure(clos, fv) ->
+      let funs ppf =
+        List.iter (fprintf ppf "@ @[<2>%a@]" one_fun) in
+      let lams ppf =
+        List.iter (fprintf ppf "@ %a" lam) in
+      fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv
+  | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i
+  | Ulet(mut, kind, id, arg, body) ->
+      let rec letbody ul = match ul with
+        | Ulet(mut, kind, id, arg, body) ->
+            fprintf ppf "@ @[<2>%a%s%s@ %a@]"
+              VP.print id
+              (mutable_flag mut) (value_kind kind) lam arg;
+            letbody body
+        | _ -> ul in
+      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a%s%s@ %a@]"
+        VP.print id (mutable_flag mut)
+          (value_kind kind) lam arg;
+      let expr = letbody body in
+      fprintf ppf ")@]@ %a)@]" lam expr
+  | Uphantom_let (id, defining_expr, body) ->
+      let rec letbody ul = match ul with
+        | Uphantom_let (id, defining_expr, body) ->
+            fprintf ppf "@ @[<2>%a@ %a@]"
+              Backend_var.With_provenance.print id
+              phantom_defining_expr_opt defining_expr;
+            letbody body
+        | _ -> ul in
+      fprintf ppf "@[<2>(phantom_let@ @[<hv 1>(@[<2>%a@ %a@]"
+        Backend_var.With_provenance.print id
+        phantom_defining_expr_opt defining_expr;
+      let expr = letbody body in
+      fprintf ppf ")@]@ %a)@]" lam expr
+  | Uletrec(id_arg_list, body) ->
+      let bindings ppf id_arg_list =
+        let spc = ref false in
+        List.iter
+          (fun (id, l) ->
+            if !spc then fprintf ppf "@ " else spc := true;
+            fprintf ppf "@[<2>%a@ %a@]"
+              VP.print id
+              lam l)
+          id_arg_list in
+      fprintf ppf
+        "@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body
+  | Uprim(prim, largs, _) ->
+      let lams ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(%a%a)@]"
+        Printclambda_primitives.primitive prim lams largs
+  | Uswitch(larg, sw, _dbg) ->
+      let print_case tag index i ppf =
+        for j = 0 to Array.length index - 1 do
+          if index.(j) = i then fprintf ppf "case %s %i:" tag j
+        done in
+      let print_cases tag index cases ppf =
+        for i = 0 to Array.length cases - 1 do
+          fprintf ppf "@ @[<2>%t@ %a@]"
+            (print_case tag index i) sequence cases.(i)
+        done in
+      let switch ppf sw =
+        print_cases "int" sw.us_index_consts sw.us_actions_consts ppf ;
+        print_cases "tag" sw.us_index_blocks sw.us_actions_blocks ppf  in
+      fprintf ppf
+       "@[<v 0>@[<2>(switch@ %a@ @]%a)@]"
+        lam larg switch sw
+  | Ustringswitch(larg,sw,d) ->
+      let switch ppf sw =
+        let spc = ref false in
+        List.iter
+          (fun (s,l) ->
+            if !spc then fprintf ppf "@ " else spc := true;
+            fprintf ppf "@[<hv 1>case \"%s\":@ %a@]"
+              (String.escaped s) lam l)
+          sw ;
+        begin match d with
+        | Some d ->
+            if !spc then fprintf ppf "@ " else spc := true;
+            fprintf ppf "@[<hv 1>default:@ %a@]" lam d
+        | None -> ()
+        end in
+      fprintf ppf
+        "@[<1>(switch %a@ @[<v 0>%a@])@]" lam larg switch sw
+  | Ustaticfail (i, ls)  ->
+      let lams ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls;
+  | Ucatch(i, vars, lbody, lhandler) ->
+      fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]"
+        lam lbody i
+        (fun ppf vars ->
+           List.iter
+             (fun (x, k) ->
+                fprintf ppf " %a%a"
+                 VP.print x
+                 Printlambda.value_kind k
+             )
+             vars
+        )
+        vars
+        lam lhandler
+  | Utrywith(lbody, param, lhandler) ->
+      fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]"
+        lam lbody VP.print param lam lhandler
+  | Uifthenelse(lcond, lif, lelse) ->
+      fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse
+  | Usequence(l1, l2) ->
+      fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2
+  | Uwhile(lcond, lbody) ->
+      fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody
+  | Ufor(param, lo, hi, dir, body) ->
+      fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]"
+       VP.print param lam lo
+       (match dir with Upto -> "to" | Downto -> "downto")
+       lam hi lam body
+  | Uassign(id, expr) ->
+      fprintf ppf "@[<2>(assign@ %a@ %a)@]" V.print id lam expr
+  | Usend (k, met, obj, largs, _) ->
+      let args ppf largs =
+        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
+      let kind =
+        if k = Lambda.Self then "self"
+        else if k = Lambda.Cached then "cache"
+        else "" in
+      fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
+  | Uunreachable ->
+      fprintf ppf "unreachable"
+
+and sequence ppf ulam = match ulam with
+  | Usequence(l1, l2) ->
+      fprintf ppf "%a@ %a" sequence l1 sequence l2
+  | _ -> lam ppf ulam
+
+let clambda ppf ulam =
+  fprintf ppf "%a@." lam ulam
+
+
+let rec approx ppf = function
+    Value_closure(fundesc, a) ->
+      Format.fprintf ppf "@[<2>function %s@ arity %i"
+        fundesc.fun_label fundesc.fun_arity;
+      if fundesc.fun_closed then begin
+        Format.fprintf ppf "@ (closed)"
+      end;
+      if fundesc.fun_inline <> None then begin
+        Format.fprintf ppf "@ (inline)"
+      end;
+      Format.fprintf ppf "@ -> @ %a@]" approx a
+  | Value_tuple a ->
+      let tuple ppf a =
+        for i = 0 to Array.length a - 1 do
+          if i > 0 then Format.fprintf ppf ";@ ";
+          Format.fprintf ppf "%i: %a" i approx a.(i)
+        done in
+      Format.fprintf ppf "@[<hov 1>(%a)@]" tuple a
+  | Value_unknown ->
+      Format.fprintf ppf "_"
+  | Value_const c ->
+      fprintf ppf "@[const(%a)@]" uconstant c
+  | Value_global_field (s, i) ->
+      fprintf ppf "@[global(%s,%i)@]" s i
diff --git a/middle_end/printclambda.mli b/middle_end/printclambda.mli
new file mode 100644
index 0000000000..121667e2a4
--- /dev/null
+++ b/middle_end/printclambda.mli
@@ -0,0 +1,26 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Clambda
+open Format
+
+val clambda: formatter -> ulambda -> unit
+val approx: formatter -> value_approximation -> unit
+val structured_constant: formatter -> ustructured_constant -> unit
+
+val phantom_defining_expr_opt
+   : formatter
+  -> uphantom_defining_expr option
+  -> unit
diff --git a/middle_end/printclambda_primitives.ml b/middle_end/printclambda_primitives.ml
new file mode 100644
index 0000000000..3f627063d4
--- /dev/null
+++ b/middle_end/printclambda_primitives.ml
@@ -0,0 +1,202 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+
+open Format
+open Asttypes
+
+let boxed_integer_name = function
+  | Lambda.Pnativeint -> "nativeint"
+  | Lambda.Pint32 -> "int32"
+  | Lambda.Pint64 -> "int64"
+
+let boxed_integer_mark name = function
+  | Lambda.Pnativeint -> Printf.sprintf "Nativeint.%s" name
+  | Lambda.Pint32 -> Printf.sprintf "Int32.%s" name
+  | Lambda.Pint64 -> Printf.sprintf "Int64.%s" name
+
+let print_boxed_integer name ppf bi =
+  fprintf ppf "%s" (boxed_integer_mark name bi);;
+
+let array_kind array_kind =
+  let open Lambda in
+  match array_kind with
+  | Pgenarray -> "gen"
+  | Paddrarray -> "addr"
+  | Pintarray -> "int"
+  | Pfloatarray -> "float"
+
+let access_size size =
+  let open Clambda_primitives in
+  match size with
+  | Sixteen -> "16"
+  | Thirty_two -> "32"
+  | Sixty_four -> "64"
+
+let access_safety safety =
+  let open Lambda in
+  match safety with
+  | Safe -> ""
+  | Unsafe -> "unsafe_"
+
+let primitive ppf (prim:Clambda_primitives.primitive) =
+  let open Lambda in
+  let open Clambda_primitives in
+  match prim with
+  | Pread_symbol sym ->
+      fprintf ppf "read_symbol %s" sym
+  | Pmakeblock(tag, Immutable, shape) ->
+      fprintf ppf "makeblock %i%a" tag Printlambda.block_shape shape
+  | Pmakeblock(tag, Mutable, shape) ->
+      fprintf ppf "makemutable %i%a" tag Printlambda.block_shape shape
+  | Pfield n -> fprintf ppf "field %i" n
+  | Pfield_computed -> fprintf ppf "field_computed"
+  | Psetfield(n, ptr, init) ->
+      let instr =
+        match ptr with
+        | Pointer -> "ptr"
+        | Immediate -> "imm"
+      in
+      let init =
+        match init with
+        | Heap_initialization -> "(heap-init)"
+        | Root_initialization -> "(root-init)"
+        | Assignment -> ""
+      in
+      fprintf ppf "setfield_%s%s %i" instr init n
+  | Psetfield_computed (ptr, init) ->
+      let instr =
+        match ptr with
+        | Pointer -> "ptr"
+        | Immediate -> "imm"
+      in
+      let init =
+        match init with
+        | Heap_initialization -> "(heap-init)"
+        | Root_initialization -> "(root-init)"
+        | Assignment -> ""
+      in
+      fprintf ppf "setfield_%s%s_computed" instr init
+  | Pfloatfield n -> fprintf ppf "floatfield %i" n
+  | Psetfloatfield (n, init) ->
+      let init =
+        match init with
+        | Heap_initialization -> "(heap-init)"
+        | Root_initialization -> "(root-init)"
+        | Assignment -> ""
+      in
+      fprintf ppf "setfloatfield%s %i" init n
+  | Pduprecord (rep, size) ->
+      fprintf ppf "duprecord %a %i" Printlambda.record_rep rep size
+  | Pccall p -> fprintf ppf "%s" p.Primitive.prim_name
+  | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k)
+  | Psequand -> fprintf ppf "&&"
+  | Psequor -> fprintf ppf "||"
+  | Pnot -> fprintf ppf "not"
+  | Pnegint -> fprintf ppf "~"
+  | Paddint -> fprintf ppf "+"
+  | Psubint -> fprintf ppf "-"
+  | Pmulint -> fprintf ppf "*"
+  | Pdivint Safe -> fprintf ppf "/"
+  | Pdivint Unsafe -> fprintf ppf "/u"
+  | Pmodint Safe -> fprintf ppf "mod"
+  | Pmodint Unsafe -> fprintf ppf "mod_unsafe"
+  | Pandint -> fprintf ppf "and"
+  | Porint -> fprintf ppf "or"
+  | Pxorint -> fprintf ppf "xor"
+  | Plslint -> fprintf ppf "lsl"
+  | Plsrint -> fprintf ppf "lsr"
+  | Pasrint -> fprintf ppf "asr"
+  | Pintcomp(cmp) -> Printlambda.integer_comparison ppf cmp
+  | Poffsetint n -> fprintf ppf "%i+" n
+  | Poffsetref n -> fprintf ppf "+:=%i"n
+  | Pintoffloat -> fprintf ppf "int_of_float"
+  | Pfloatofint -> fprintf ppf "float_of_int"
+  | Pnegfloat -> fprintf ppf "~."
+  | Pabsfloat -> fprintf ppf "abs."
+  | Paddfloat -> fprintf ppf "+."
+  | Psubfloat -> fprintf ppf "-."
+  | Pmulfloat -> fprintf ppf "*."
+  | Pdivfloat -> fprintf ppf "/."
+  | Pfloatcomp(cmp) -> Printlambda.float_comparison ppf cmp
+  | Pstringlength -> fprintf ppf "string.length"
+  | Pstringrefu -> fprintf ppf "string.unsafe_get"
+  | Pstringrefs -> fprintf ppf "string.get"
+  | Pbyteslength -> fprintf ppf "bytes.length"
+  | Pbytesrefu -> fprintf ppf "bytes.unsafe_get"
+  | Pbytessetu -> fprintf ppf "bytes.unsafe_set"
+  | Pbytesrefs -> fprintf ppf "bytes.get"
+  | Pbytessets -> fprintf ppf "bytes.set"
+
+  | Parraylength k -> fprintf ppf "array.length[%s]" (array_kind k)
+  | Pmakearray (k, Mutable) -> fprintf ppf "makearray[%s]" (array_kind k)
+  | Pmakearray (k, Immutable) -> fprintf ppf "makearray_imm[%s]" (array_kind k)
+  | Pduparray (k, Mutable) -> fprintf ppf "duparray[%s]" (array_kind k)
+  | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k)
+  | Parrayrefu k -> fprintf ppf "array.unsafe_get[%s]" (array_kind k)
+  | Parraysetu k -> fprintf ppf "array.unsafe_set[%s]" (array_kind k)
+  | Parrayrefs k -> fprintf ppf "array.get[%s]" (array_kind k)
+  | Parraysets k -> fprintf ppf "array.set[%s]" (array_kind k)
+  | Pisint -> fprintf ppf "isint"
+  | Pisout -> fprintf ppf "isout"
+  | Pbintofint bi -> print_boxed_integer "of_int" ppf bi
+  | Pintofbint bi -> print_boxed_integer "to_int" ppf bi
+  | Pcvtbint (bi1, bi2) ->
+      fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1)
+  | Pnegbint bi -> print_boxed_integer "neg" ppf bi
+  | Paddbint bi -> print_boxed_integer "add" ppf bi
+  | Psubbint bi -> print_boxed_integer "sub" ppf bi
+  | Pmulbint bi -> print_boxed_integer "mul" ppf bi
+  | Pdivbint { size = bi; is_safe = Safe } ->
+      print_boxed_integer "div" ppf bi
+  | Pdivbint { size = bi; is_safe = Unsafe } ->
+      print_boxed_integer "div_unsafe" ppf bi
+  | Pmodbint { size = bi; is_safe = Safe } ->
+      print_boxed_integer "mod" ppf bi
+  | Pmodbint { size = bi; is_safe = Unsafe } ->
+      print_boxed_integer "mod_unsafe" ppf bi
+  | Pandbint bi -> print_boxed_integer "and" ppf bi
+  | Porbint bi -> print_boxed_integer "or" ppf bi
+  | Pxorbint bi -> print_boxed_integer "xor" ppf bi
+  | Plslbint bi -> print_boxed_integer "lsl" ppf bi
+  | Plsrbint bi -> print_boxed_integer "lsr" ppf bi
+  | Pasrbint bi -> print_boxed_integer "asr" ppf bi
+  | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi
+  | Pbintcomp(bi, Cne) -> print_boxed_integer "!=" ppf bi
+  | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi
+  | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi
+  | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi
+  | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi
+  | Pbigarrayref(unsafe, _n, kind, layout) ->
+      Printlambda.print_bigarray "get" unsafe kind ppf layout
+  | Pbigarrayset(unsafe, _n, kind, layout) ->
+      Printlambda.print_bigarray "set" unsafe kind ppf layout
+  | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n
+  | Pstring_load(size, safety) ->
+      fprintf ppf "string.%sget%s" (access_safety safety) (access_size size)
+  | Pbytes_load(size, safety) ->
+      fprintf ppf "bytes.%sget%s" (access_safety safety) (access_size size)
+  | Pbytes_set(size, safety) ->
+      fprintf ppf "bytes.%sset%s" (access_safety safety) (access_size size)
+  | Pbigstring_load(size, safety) ->
+      fprintf ppf "bigarray.array1.%sget%s"
+        (access_safety safety) (access_size size)
+  | Pbigstring_set(size, safety) ->
+      fprintf ppf "bigarray.array1.%sset%s"
+        (access_safety safety) (access_size size)
+  | Pbswap16 -> fprintf ppf "bswap16"
+  | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi
+  | Pint_as_pointer -> fprintf ppf "int_as_pointer"
+  | Popaque -> fprintf ppf "opaque"
diff --git a/middle_end/printclambda_primitives.mli b/middle_end/printclambda_primitives.mli
new file mode 100644
index 0000000000..07db5a1ce6
--- /dev/null
+++ b/middle_end/printclambda_primitives.mli
@@ -0,0 +1,18 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*             Xavier Leroy, projet Cristal, INRIA Rocquencourt           *)
+(*                                                                        *)
+(*   Copyright 1996 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Format
+
+val primitive: formatter -> Clambda_primitives.primitive -> unit
diff --git a/middle_end/semantics_of_primitives.ml b/middle_end/semantics_of_primitives.ml
new file mode 100644
index 0000000000..2daf167ecd
--- /dev/null
+++ b/middle_end/semantics_of_primitives.ml
@@ -0,0 +1,153 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+type effects = No_effects | Only_generative_effects | Arbitrary_effects
+type coeffects = No_coeffects | Has_coeffects
+
+let for_primitive (prim : Clambda_primitives.primitive) =
+  match prim with
+  | Pmakeblock _
+  | Pmakearray (_, Mutable) -> Only_generative_effects, No_coeffects
+  | Pmakearray (_, Immutable) -> No_effects, No_coeffects
+  | Pduparray (_, Immutable) ->
+      No_effects, No_coeffects  (* Pduparray (_, Immutable) is allowed only on
+                                   immutable arrays. *)
+  | Pduparray (_, Mutable) | Pduprecord _ ->
+      Only_generative_effects, Has_coeffects
+  | Pccall { prim_name =
+               ( "caml_format_float" | "caml_format_int" | "caml_int32_format"
+               | "caml_nativeint_format" | "caml_int64_format" ) } ->
+      No_effects, No_coeffects
+  | Pccall _ -> Arbitrary_effects, Has_coeffects
+  | Praise _ -> Arbitrary_effects, No_coeffects
+  | Pnot
+  | Pnegint
+  | Paddint
+  | Psubint
+  | Pmulint
+  | Pandint
+  | Porint
+  | Pxorint
+  | Plslint
+  | Plsrint
+  | Pasrint
+  | Pintcomp _ -> No_effects, No_coeffects
+  | Pdivbint { is_safe = Unsafe }
+  | Pmodbint { is_safe = Unsafe }
+  | Pdivint Unsafe
+  | Pmodint Unsafe ->
+      No_effects, No_coeffects  (* Will not raise [Division_by_zero]. *)
+  | Pdivbint { is_safe = Safe }
+  | Pmodbint { is_safe = Safe }
+  | Pdivint Safe
+  | Pmodint Safe ->
+      Arbitrary_effects, No_coeffects
+  | Poffsetint _ -> No_effects, No_coeffects
+  | Poffsetref _ -> Arbitrary_effects, Has_coeffects
+  | Pintoffloat
+  | Pfloatofint
+  | Pnegfloat
+  | Pabsfloat
+  | Paddfloat
+  | Psubfloat
+  | Pmulfloat
+  | Pdivfloat
+  | Pfloatcomp _ -> No_effects, No_coeffects
+  | Pstringlength | Pbyteslength
+  | Parraylength _ ->
+      No_effects, Has_coeffects  (* That old chestnut: [Obj.truncate]. *)
+  | Pisint
+  | Pisout
+  | Pbintofint _
+  | Pintofbint _
+  | Pcvtbint _
+  | Pnegbint _
+  | Paddbint _
+  | Psubbint _
+  | Pmulbint _
+  | Pandbint _
+  | Porbint _
+  | Pxorbint _
+  | Plslbint _
+  | Plsrbint _
+  | Pasrbint _
+  | Pbintcomp _ -> No_effects, No_coeffects
+  | Pbigarraydim _ ->
+      No_effects, Has_coeffects  (* Some people resize bigarrays in place. *)
+  | Pread_symbol _
+  | Pfield _
+  | Pfield_computed
+  | Pfloatfield _
+  | Parrayrefu _
+  | Pstringrefu
+  | Pbytesrefu
+  | Pstring_load (_, Unsafe)
+  | Pbytes_load (_, Unsafe)
+  | Pbigarrayref (true, _, _, _)
+  | Pbigstring_load (_, Unsafe) ->
+      No_effects, Has_coeffects
+  | Parrayrefs _
+  | Pstringrefs
+  | Pbytesrefs
+  | Pstring_load (_, Safe)
+  | Pbytes_load (_, Safe)
+  | Pbigarrayref (false, _, _, _)
+  | Pbigstring_load (_, Safe) ->
+      (* May trigger a bounds check exception. *)
+      Arbitrary_effects, Has_coeffects
+  | Psetfield _
+  | Psetfield_computed _
+  | Psetfloatfield _
+  | Parraysetu _
+  | Parraysets _
+  | Pbytessetu
+  | Pbytessets
+  | Pbytes_set _
+  | Pbigarrayset _
+  | Pbigstring_set _ ->
+      (* Whether or not some of these are "unsafe" is irrelevant; they always
+         have an effect. *)
+      Arbitrary_effects, No_coeffects
+  | Pbswap16
+  | Pbbswap _ -> No_effects, No_coeffects
+  | Pint_as_pointer -> No_effects, No_coeffects
+  | Popaque -> Arbitrary_effects, Has_coeffects
+  | Psequand
+  | Psequor ->
+      (* Removed by [Closure_conversion] in the flambda pipeline. *)
+      No_effects, No_coeffects
+
+type return_type =
+  | Float
+  | Other
+
+let return_type_of_primitive (prim:Clambda_primitives.primitive) =
+  match prim with
+  | Pfloatofint
+  | Pnegfloat
+  | Pabsfloat
+  | Paddfloat
+  | Psubfloat
+  | Pmulfloat
+  | Pdivfloat
+  | Pfloatfield _
+  | Parrayrefu Pfloatarray
+  | Parrayrefs Pfloatarray ->
+      Float
+  | _ ->
+      Other
diff --git a/middle_end/semantics_of_primitives.mli b/middle_end/semantics_of_primitives.mli
new file mode 100644
index 0000000000..78407df71d
--- /dev/null
+++ b/middle_end/semantics_of_primitives.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 Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+[@@@ocaml.warning "+a-4-9-30-40-41-42"]
+
+(** Description of the semantics of primitives, to be used for optimization
+    purposes.
+
+    "No effects" means that the primitive does not change the observable state
+    of the world.  For example, it must not write to any mutable storage,
+    call arbitrary external functions or change control flow (e.g. by raising
+    an exception).  Note that allocation is not "No effects" (see below).
+
+    It is assumed in the compiler that applications of primitives with no
+    effects, whose results are not used, may be eliminated.  It is further
+    assumed that applications of primitives with no effects may be
+    duplicated (and thus possibly executed more than once).
+
+    (Exceptions arising from allocation points, for example "out of memory" or
+    exceptions propagated from finalizers or signal handlers, are treated as
+    "effects out of the ether" and thus ignored for our determination here
+    of effectfulness.  The same goes for floating point operations that may
+    cause hardware traps on some platforms.)
+
+    "Only generative effects" means that a primitive does not change the
+    observable state of the world save for possibly affecting the state of
+    the garbage collector by performing an allocation.  Applications of
+    primitives that only have generative effects and whose results are unused
+    may be eliminated by the compiler.  However, unlike "No effects"
+    primitives, such applications will never be eligible for duplication.
+
+    "Arbitrary effects" covers all other primitives.
+
+    "No coeffects" means that the primitive does not observe the effects (in
+    the sense described above) of other expressions.  For example, it must not
+    read from any mutable storage or call arbitrary external functions.
+
+    It is assumed in the compiler that, subject to data dependencies,
+    expressions with neither effects nor coeffects may be reordered with
+    respect to other expressions.
+*)
+
+type effects = No_effects | Only_generative_effects | Arbitrary_effects
+type coeffects = No_coeffects | Has_coeffects
+
+(** Describe the semantics of a primitive.  This does not take into account of
+    the (non-)(co)effectfulness of the arguments in a primitive application.
+    To determine whether such an application is (co)effectful, the arguments
+    must also be analysed. *)
+val for_primitive: Clambda_primitives.primitive -> effects * coeffects
+
+type return_type =
+  | Float
+  | Other
+
+val return_type_of_primitive: Clambda_primitives.primitive -> return_type
diff --git a/middle_end/base_types/symbol.ml b/middle_end/symbol.ml
index 22a2e0a70e..22a2e0a70e 100644
--- a/middle_end/base_types/symbol.ml
+++ b/middle_end/symbol.ml
diff --git a/middle_end/base_types/symbol.mli b/middle_end/symbol.mli
index d2771af244..d2771af244 100644
--- a/middle_end/base_types/symbol.mli
+++ b/middle_end/symbol.mli
diff --git a/middle_end/base_types/variable.ml b/middle_end/variable.ml
index 64099a73b6..64099a73b6 100644
--- a/middle_end/base_types/variable.ml
+++ b/middle_end/variable.ml
diff --git a/middle_end/base_types/variable.mli b/middle_end/variable.mli
index b5d3f136ae..b5d3f136ae 100644
--- a/middle_end/base_types/variable.mli
+++ b/middle_end/variable.mli