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.

26 files changed, 0 insertions, 12492 deletions

diff --git a/bytecomp/cmo_format.mli b/bytecomp/cmo_format.mli
deleted file mode 100644
index d953a8817a..0000000000
--- a/bytecomp/cmo_format.mli
+++ /dev/null
@@ -1,66 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Xavier Leroy, projet Cristal, 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.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Symbol table information for .cmo and .cma files *)
-
-open Misc
-
-(* Relocation information *)
-
-type reloc_info =
-    Reloc_literal of Lambda.structured_constant    (* structured constant *)
-  | Reloc_getglobal of Ident.t              (* reference to a global *)
-  | Reloc_setglobal of Ident.t              (* definition of a global *)
-  | Reloc_primitive of string               (* C primitive number *)
-
-(* Descriptor for compilation units *)
-
-type compilation_unit =
-  { cu_name: modname;                   (* Name of compilation unit *)
-    mutable cu_pos: int;                (* Absolute position in file *)
-    cu_codesize: int;                   (* Size of code block *)
-    cu_reloc: (reloc_info * int) list;  (* Relocation information *)
-    cu_imports: crcs;                   (* Names and CRC of intfs imported *)
-    cu_required_globals: Ident.t list;  (* Compilation units whose
-                                           initialization side effects
-                                           must occur before this one. *)
-    cu_primitives: string list;         (* Primitives declared inside *)
-    mutable cu_force_link: bool;        (* Must be linked even if unref'ed *)
-    mutable cu_debug: int;              (* Position of debugging info, or 0 *)
-    cu_debugsize: int }                 (* Length of debugging info *)
-
-(* Format of a .cmo file:
-     magic number (Config.cmo_magic_number)
-     absolute offset of compilation unit descriptor
-     block of relocatable bytecode
-     debugging information if any
-     compilation unit descriptor *)
-
-(* Descriptor for libraries *)
-
-type library =
-  { lib_units: compilation_unit list;   (* List of compilation units *)
-    lib_custom: bool;                   (* Requires custom mode linking? *)
-    lib_ccobjs: string list;            (* C object files needed for -custom *)
-    lib_ccopts: string list;            (* Extra opts to C compiler *)
-    lib_dllibs: string list }           (* DLLs needed *)
-
-(* Format of a .cma file:
-     magic number (Config.cma_magic_number)
-     absolute offset of library descriptor
-     object code for first library member
-     ...
-     object code for last library member
-     library descriptor *)
diff --git a/bytecomp/dune b/bytecomp/dune
index b2409cf4f1..655cb57ebe 100644
--- a/bytecomp/dune
+++ b/bytecomp/dune
@@ -18,11 +18,3 @@
  (deps    (:instr (file ../runtime/caml/instruct.h)))
  (action
   (bash "%{dep:../tools/make_opcodes.exe} -opcodes < %{instr} > %{targets}")))
-
-(rule
- (targets runtimedef.ml)
- (mode    fallback)
- (deps    (:fail (file ../runtime/caml/fail.h))
-          (:prim (file ../runtime/primitives)))
- (action  (with-stdout-to %{targets}
-            (run ./generate_runtimedef.sh %{fail} %{prim}))))
diff --git a/bytecomp/generate_runtimedef.sh b/bytecomp/generate_runtimedef.sh
deleted file mode 100755
index 66ccf3ce5d..0000000000
--- a/bytecomp/generate_runtimedef.sh
+++ /dev/null
@@ -1,25 +0,0 @@
-#!/bin/sh
-
-#**************************************************************************
-#*                                                                        *
-#*                                 OCaml                                  *
-#*                                                                        *
-#*            Xavier Leroy, projet Cristal, INRIA Rocquencourt            *
-#*                                                                        *
-#*   Copyright 1999 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.          *
-#*                                                                        *
-#**************************************************************************
-
-echo 'let builtin_exceptions = [|'
-cat "$1" | tr -d '\r' | \
-    sed -n -e 's|.*/\* \("[A-Za-z_]*"\) \*/$|  \1;|p'
-echo '|]'
-
-echo 'let builtin_primitives = [|'
-sed -e 's/.*/  "&";/' "$2"
-echo '|]'
diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
deleted file mode 100644
index f06d9a820d..0000000000
--- a/bytecomp/lambda.ml
+++ /dev/null
@@ -1,886 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 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 Misc
-open Asttypes
-
-type compile_time_constant =
-  | Big_endian
-  | Word_size
-  | Int_size
-  | Max_wosize
-  | Ostype_unix
-  | Ostype_win32
-  | Ostype_cygwin
-  | Backend_type
-
-type immediate_or_pointer =
-  | Immediate
-  | Pointer
-
-type initialization_or_assignment =
-  | Assignment
-  | Heap_initialization
-  | Root_initialization
-
-type is_safe =
-  | Safe
-  | Unsafe
-
-type primitive =
-  | Pidentity
-  | Pbytes_to_string
-  | Pbytes_of_string
-  | Pignore
-  | Prevapply
-  | Pdirapply
-    (* Globals *)
-  | Pgetglobal of Ident.t
-  | Psetglobal of Ident.t
-  (* 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
-  (* Force lazy values *)
-  (* 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
-  | 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 Bigarrays: (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 Bigarray *)
-  | Pbigarraydim of int
-  (* load/set 16,32,64 bits from a string: (unsafe)*)
-  | Pstring_load_16 of bool
-  | Pstring_load_32 of bool
-  | Pstring_load_64 of bool
-  | Pbytes_load_16 of bool
-  | Pbytes_load_32 of bool
-  | Pbytes_load_64 of bool
-  | Pbytes_set_16 of bool
-  | Pbytes_set_32 of bool
-  | Pbytes_set_64 of bool
-  (* load/set 16,32,64 bits from a
-     (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
-  | Pbigstring_load_16 of bool
-  | Pbigstring_load_32 of bool
-  | Pbigstring_load_64 of bool
-  | Pbigstring_set_16 of bool
-  | Pbigstring_set_32 of bool
-  | Pbigstring_set_64 of bool
-  (* Compile time constants *)
-  | Pctconst of compile_time_constant
-  (* byte swap *)
-  | Pbswap16
-  | Pbbswap of boxed_integer
-  (* Integer to external pointer *)
-  | Pint_as_pointer
-  (* Inhibition of optimisation *)
-  | Popaque
-
-and integer_comparison =
-    Ceq | Cne | Clt | Cgt | Cle | Cge
-
-and float_comparison =
-    CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge
-
-and value_kind =
-    Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
-
-and block_shape =
-  value_kind list option
-
-and array_kind =
-    Pgenarray | Paddrarray | Pintarray | Pfloatarray
-
-and boxed_integer = Primitive.boxed_integer =
-    Pnativeint | Pint32 | Pint64
-
-and 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 =
-    Pbigarray_unknown_layout
-  | Pbigarray_c_layout
-  | Pbigarray_fortran_layout
-
-and raise_kind =
-  | Raise_regular
-  | Raise_reraise
-  | Raise_notrace
-
-let equal_boxed_integer x y =
-  match x, y with
-  | Pnativeint, Pnativeint
-  | Pint32, Pint32
-  | Pint64, Pint64 ->
-    true
-  | (Pnativeint | Pint32 | Pint64), _ ->
-    false
-
-let equal_primitive =
-  (* Should be implemented like [equal_value_kind] of [equal_boxed_integer],
-     i.e. by matching over the various constructors but the type has more
-     than 100 constructors... *)
-  (=)
-
-let equal_value_kind x y =
-  match x, y with
-  | Pgenval, Pgenval -> true
-  | Pfloatval, Pfloatval -> true
-  | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2
-  | Pintval, Pintval -> true
-  | (Pgenval | Pfloatval | Pboxedintval _ | Pintval), _ -> false
-
-
-type structured_constant =
-    Const_base of constant
-  | Const_pointer of int
-  | Const_block of int * structured_constant list
-  | Const_float_array of string list
-  | Const_immstring of string
-
-type inline_attribute =
-  | Always_inline (* [@inline] or [@inline always] *)
-  | Never_inline (* [@inline never] *)
-  | Unroll of int (* [@unroll x] *)
-  | Default_inline (* no [@inline] attribute *)
-
-let equal_inline_attribute x y =
-  match x, y with
-  | Always_inline, Always_inline
-  | Never_inline, Never_inline
-  | Default_inline, Default_inline
-    ->
-    true
-  | Unroll u, Unroll v ->
-    u = v
-  | (Always_inline | Never_inline | Unroll _ | Default_inline), _ ->
-    false
-
-type specialise_attribute =
-  | Always_specialise (* [@specialise] or [@specialise always] *)
-  | Never_specialise (* [@specialise never] *)
-  | Default_specialise (* no [@specialise] attribute *)
-
-let equal_specialise_attribute x y =
-  match x, y with
-  | Always_specialise, Always_specialise
-  | Never_specialise, Never_specialise
-  | Default_specialise, Default_specialise ->
-    true
-  | (Always_specialise | Never_specialise | Default_specialise), _ ->
-    false
-
-type local_attribute =
-  | Always_local (* [@local] or [@local always] *)
-  | Never_local (* [@local never] *)
-  | Default_local (* [@local maybe] or no [@local] attribute *)
-
-type function_kind = Curried | Tupled
-
-type let_kind = Strict | Alias | StrictOpt | Variable
-
-type meth_kind = Self | Public | Cached
-
-let equal_meth_kind x y =
-  match x, y with
-  | Self, Self -> true
-  | Public, Public -> true
-  | Cached, Cached -> true
-  | (Self | Public | Cached), _ -> false
-
-type shared_code = (int * int) list
-
-type function_attribute = {
-  inline : inline_attribute;
-  specialise : specialise_attribute;
-  local: local_attribute;
-  is_a_functor: bool;
-  stub: bool;
-}
-
-type lambda =
-    Lvar of Ident.t
-  | Lconst of structured_constant
-  | Lapply of lambda_apply
-  | Lfunction of lfunction
-  | Llet of let_kind * value_kind * Ident.t * lambda * lambda
-  | Lletrec of (Ident.t * lambda) list * lambda
-  | Lprim of primitive * lambda list * Location.t
-  | Lswitch of lambda * lambda_switch * Location.t
-  | Lstringswitch of
-      lambda * (string * lambda) list * lambda option * Location.t
-  | Lstaticraise of int * lambda list
-  | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda
-  | Ltrywith of lambda * Ident.t * lambda
-  | Lifthenelse of lambda * lambda * lambda
-  | Lsequence of lambda * lambda
-  | Lwhile of lambda * lambda
-  | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
-  | Lassign of Ident.t * lambda
-  | Lsend of meth_kind * lambda * lambda * lambda list * Location.t
-  | Levent of lambda * lambda_event
-  | Lifused of Ident.t * lambda
-
-and lfunction =
-  { kind: function_kind;
-    params: (Ident.t * value_kind) list;
-    return: value_kind;
-    body: lambda;
-    attr: function_attribute; (* specified with [@inline] attribute *)
-    loc: Location.t; }
-
-and lambda_apply =
-  { ap_func : lambda;
-    ap_args : lambda list;
-    ap_loc : Location.t;
-    ap_should_be_tailcall : bool;
-    ap_inlined : inline_attribute;
-    ap_specialised : specialise_attribute; }
-
-and lambda_switch =
-  { sw_numconsts: int;
-    sw_consts: (int * lambda) list;
-    sw_numblocks: int;
-    sw_blocks: (int * lambda) list;
-    sw_failaction : lambda option}
-
-and lambda_event =
-  { lev_loc: Location.t;
-    lev_kind: lambda_event_kind;
-    lev_repr: int ref option;
-    lev_env: Env.t }
-
-and lambda_event_kind =
-    Lev_before
-  | Lev_after of Types.type_expr
-  | Lev_function
-  | Lev_pseudo
-  | Lev_module_definition of Ident.t
-
-type program =
-  { module_ident : Ident.t;
-    main_module_block_size : int;
-    required_globals : Ident.Set.t;
-    code : lambda }
-
-let const_unit = Const_pointer 0
-
-let lambda_unit = Lconst const_unit
-
-let default_function_attribute = {
-  inline = Default_inline;
-  specialise = Default_specialise;
-  local = Default_local;
-  is_a_functor = false;
-  stub = false;
-}
-
-let default_stub_attribute =
-  { default_function_attribute with stub = true }
-
-(* Build sharing keys *)
-(*
-   Those keys are later compared with Stdlib.compare.
-   For that reason, they should not include cycles.
-*)
-
-exception Not_simple
-
-let max_raw = 32
-
-let make_key e =
-  let count = ref 0   (* Used for controlling size *)
-  and make_key = Ident.make_key_generator () in
-  (* make_key is used for normalizing let-bound variables *)
-  let rec tr_rec env e =
-    incr count ;
-    if !count > max_raw then raise Not_simple ; (* Too big ! *)
-    match e with
-    | Lvar id ->
-      begin
-        try Ident.find_same id env
-        with Not_found -> e
-      end
-    | Lconst  (Const_base (Const_string _)) ->
-        (* Mutable constants are not shared *)
-        raise Not_simple
-    | Lconst _ -> e
-    | Lapply ap ->
-        Lapply {ap with ap_func = tr_rec env ap.ap_func;
-                        ap_args = tr_recs env ap.ap_args;
-                        ap_loc = Location.none}
-    | Llet (Alias,_k,x,ex,e) -> (* Ignore aliases -> substitute *)
-        let ex = tr_rec env ex in
-        tr_rec (Ident.add x ex env) e
-    | Llet ((Strict | StrictOpt),_k,x,ex,Lvar v) when Ident.same v x ->
-        tr_rec env ex
-    | Llet (str,k,x,ex,e) ->
-     (* Because of side effects, keep other lets with normalized names *)
-        let ex = tr_rec env ex in
-        let y = make_key x in
-        Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e)
-    | Lprim (p,es,_) ->
-        Lprim (p,tr_recs env es, Location.none)
-    | Lswitch (e,sw,loc) ->
-        Lswitch (tr_rec env e,tr_sw env sw,loc)
-    | Lstringswitch (e,sw,d,_) ->
-        Lstringswitch
-          (tr_rec env e,
-           List.map (fun (s,e) -> s,tr_rec env e) sw,
-           tr_opt env d,
-          Location.none)
-    | Lstaticraise (i,es) ->
-        Lstaticraise (i,tr_recs env es)
-    | Lstaticcatch (e1,xs,e2) ->
-        Lstaticcatch (tr_rec env e1,xs,tr_rec env e2)
-    | Ltrywith (e1,x,e2) ->
-        Ltrywith (tr_rec env e1,x,tr_rec env e2)
-    | Lifthenelse (cond,ifso,ifnot) ->
-        Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot)
-    | Lsequence (e1,e2) ->
-        Lsequence (tr_rec env e1,tr_rec env e2)
-    | Lassign (x,e) ->
-        Lassign (x,tr_rec env e)
-    | Lsend (m,e1,e2,es,_loc) ->
-        Lsend (m,tr_rec env e1,tr_rec env e2,tr_recs env es,Location.none)
-    | Lifused (id,e) -> Lifused (id,tr_rec env e)
-    | Lletrec _|Lfunction _
-    | Lfor _ | Lwhile _
-(* Beware: (PR#6412) the event argument to Levent
-   may include cyclic structure of type Type.typexpr *)
-    | Levent _  ->
-        raise Not_simple
-
-  and tr_recs env es = List.map (tr_rec env) es
-
-  and tr_sw env sw =
-    { sw with
-      sw_consts = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_consts ;
-      sw_blocks = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_blocks ;
-      sw_failaction = tr_opt env sw.sw_failaction ; }
-
-  and tr_opt env = function
-    | None -> None
-    | Some e -> Some (tr_rec env e) in
-
-  try
-    Some (tr_rec Ident.empty e)
-  with Not_simple -> None
-
-(***************)
-
-let name_lambda strict arg fn =
-  match arg with
-    Lvar id -> fn id
-  | _ ->
-      let id = Ident.create_local "let" in
-      Llet(strict, Pgenval, id, arg, fn id)
-
-let name_lambda_list args fn =
-  let rec name_list names = function
-    [] -> fn (List.rev names)
-  | (Lvar _ as arg) :: rem ->
-      name_list (arg :: names) rem
-  | arg :: rem ->
-      let id = Ident.create_local "let" in
-      Llet(Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) in
-  name_list [] args
-
-
-let iter_opt f = function
-  | None -> ()
-  | Some e -> f e
-
-let shallow_iter ~tail ~non_tail:f = function
-    Lvar _
-  | Lconst _ -> ()
-  | Lapply{ap_func = fn; ap_args = args} ->
-      f fn; List.iter f args
-  | Lfunction{body} ->
-      f body
-  | Llet(_str, _k, _id, arg, body) ->
-      f arg; tail body
-  | Lletrec(decl, body) ->
-      tail body;
-      List.iter (fun (_id, exp) -> f exp) decl
-  | Lprim (Pidentity, [l], _) ->
-      tail l
-  | Lprim (Psequand, [l1; l2], _)
-  | Lprim (Psequor, [l1; l2], _) ->
-      f l1;
-      tail l2
-  | Lprim(_p, args, _loc) ->
-      List.iter f args
-  | Lswitch(arg, sw,_) ->
-      f arg;
-      List.iter (fun (_key, case) -> tail case) sw.sw_consts;
-      List.iter (fun (_key, case) -> tail case) sw.sw_blocks;
-      iter_opt tail sw.sw_failaction
-  | Lstringswitch (arg,cases,default,_) ->
-      f arg ;
-      List.iter (fun (_,act) -> tail act) cases ;
-      iter_opt tail default
-  | Lstaticraise (_,args) ->
-      List.iter f args
-  | Lstaticcatch(e1, _, e2) ->
-      tail e1; tail e2
-  | Ltrywith(e1, _, e2) ->
-      f e1; tail e2
-  | Lifthenelse(e1, e2, e3) ->
-      f e1; tail e2; tail e3
-  | Lsequence(e1, e2) ->
-      f e1; tail e2
-  | Lwhile(e1, e2) ->
-      f e1; f e2
-  | Lfor(_v, e1, e2, _dir, e3) ->
-      f e1; f e2; f e3
-  | Lassign(_, e) ->
-      f e
-  | Lsend (_k, met, obj, args, _) ->
-      List.iter f (met::obj::args)
-  | Levent (e, _evt) ->
-      tail e
-  | Lifused (_v, e) ->
-      tail e
-
-let iter_head_constructor f l =
-  shallow_iter ~tail:f ~non_tail:f l
-
-let rec free_variables = function
-  | Lvar id -> Ident.Set.singleton id
-  | Lconst _ -> Ident.Set.empty
-  | Lapply{ap_func = fn; ap_args = args} ->
-      free_variables_list (free_variables fn) args
-  | Lfunction{body; params} ->
-      Ident.Set.diff (free_variables body)
-        (Ident.Set.of_list (List.map fst params))
-  | Llet(_str, _k, id, arg, body) ->
-      Ident.Set.union
-        (free_variables arg)
-        (Ident.Set.remove id (free_variables body))
-  | Lletrec(decl, body) ->
-      let set = free_variables_list (free_variables body) (List.map snd decl) in
-      Ident.Set.diff set (Ident.Set.of_list (List.map fst decl))
-  | Lprim(_p, args, _loc) ->
-      free_variables_list Ident.Set.empty args
-  | Lswitch(arg, sw,_) ->
-      let set =
-        free_variables_list
-          (free_variables_list (free_variables arg)
-             (List.map snd sw.sw_consts))
-          (List.map snd sw.sw_blocks)
-      in
-      begin match sw.sw_failaction with
-      | None -> set
-      | Some failaction -> Ident.Set.union set (free_variables failaction)
-      end
-  | Lstringswitch (arg,cases,default,_) ->
-      let set =
-        free_variables_list (free_variables arg)
-          (List.map snd cases)
-      in
-      begin match default with
-      | None -> set
-      | Some default -> Ident.Set.union set (free_variables default)
-      end
-  | Lstaticraise (_,args) ->
-      free_variables_list Ident.Set.empty args
-  | Lstaticcatch(body, (_, params), handler) ->
-      Ident.Set.union
-        (Ident.Set.diff
-           (free_variables handler)
-           (Ident.Set.of_list (List.map fst params)))
-        (free_variables body)
-  | Ltrywith(body, param, handler) ->
-      Ident.Set.union
-        (Ident.Set.remove
-           param
-           (free_variables handler))
-        (free_variables body)
-  | Lifthenelse(e1, e2, e3) ->
-      Ident.Set.union
-        (Ident.Set.union (free_variables e1) (free_variables e2))
-        (free_variables e3)
-  | Lsequence(e1, e2) ->
-      Ident.Set.union (free_variables e1) (free_variables e2)
-  | Lwhile(e1, e2) ->
-      Ident.Set.union (free_variables e1) (free_variables e2)
-  | Lfor(v, lo, hi, _dir, body) ->
-      let set = Ident.Set.union (free_variables lo) (free_variables hi) in
-      Ident.Set.union set (Ident.Set.remove v (free_variables body))
-  | Lassign(id, e) ->
-      Ident.Set.add id (free_variables e)
-  | Lsend (_k, met, obj, args, _) ->
-      free_variables_list
-        (Ident.Set.union (free_variables met) (free_variables obj))
-        args
-  | Levent (lam, _evt) ->
-      free_variables lam
-  | Lifused (_v, e) ->
-      (* Shouldn't v be considered a free variable ? *)
-      free_variables e
-
-and free_variables_list set exprs =
-  List.fold_left (fun set expr -> Ident.Set.union (free_variables expr) set)
-    set exprs
-
-(* Check if an action has a "when" guard *)
-let raise_count = ref 0
-
-let next_raise_count () =
-  incr raise_count ;
-  !raise_count
-
-(* Anticipated staticraise, for guards *)
-let staticfail = Lstaticraise (0,[])
-
-let rec is_guarded = function
-  | Lifthenelse(_cond, _body, Lstaticraise (0,[])) -> true
-  | Llet(_str, _k, _id, _lam, body) -> is_guarded body
-  | Levent(lam, _ev) -> is_guarded lam
-  | _ -> false
-
-let rec patch_guarded patch = function
-  | Lifthenelse (cond, body, Lstaticraise (0,[])) ->
-      Lifthenelse (cond, body, patch)
-  | Llet(str, k, id, lam, body) ->
-      Llet (str, k, id, lam, patch_guarded patch body)
-  | Levent(lam, ev) ->
-      Levent (patch_guarded patch lam, ev)
-  | _ -> fatal_error "Lambda.patch_guarded"
-
-(* Translate an access path *)
-
-let rec transl_address loc = function
-  | Env.Aident id ->
-      if Ident.global id
-      then Lprim(Pgetglobal id, [], loc)
-      else Lvar id
-  | Env.Adot(addr, pos) ->
-      Lprim(Pfield pos, [transl_address loc addr], loc)
-
-let transl_path find loc env path =
-  match find path env with
-  | exception Not_found ->
-      fatal_error ("Cannot find address for: " ^ (Path.name path))
-  | addr -> transl_address loc addr
-
-(* Translation of identifiers *)
-
-let transl_module_path loc env path =
-  transl_path Env.find_module_address loc env path
-
-let transl_value_path loc env path =
-  transl_path Env.find_value_address loc env path
-
-let transl_extension_path loc env path =
-  transl_path Env.find_constructor_address loc env path
-
-let transl_class_path loc env path =
-  transl_path Env.find_class_address loc env path
-
-let transl_prim mod_name name =
-  let pers = Ident.create_persistent mod_name in
-  let env = Env.add_persistent_structure pers Env.empty in
-  let lid = Longident.Ldot (Longident.Lident mod_name, name) in
-  match Env.lookup_value lid env with
-  | path, _ -> transl_value_path Location.none env path
-  | exception Not_found ->
-      fatal_error ("Primitive " ^ name ^ " not found.")
-
-(* Compile a sequence of expressions *)
-
-let rec make_sequence fn = function
-    [] -> lambda_unit
-  | [x] -> fn x
-  | x::rem ->
-      let lam = fn x in Lsequence(lam, make_sequence fn rem)
-
-(* Apply a substitution to a lambda-term.
-   Assumes that the image of the substitution is out of reach
-   of the bound variables of the lambda-term (no capture). *)
-
-let subst update_env s lam =
-  let rec subst s lam =
-    let remove_list l s =
-      List.fold_left (fun s (id, _kind) -> Ident.Map.remove id s) s l
-    in
-    let module M = Ident.Map in
-    match lam with
-    | Lvar id as l ->
-        begin try Ident.Map.find id s with Not_found -> l end
-    | Lconst _ as l -> l
-    | Lapply ap ->
-        Lapply{ap with ap_func = subst s ap.ap_func;
-                      ap_args = subst_list s ap.ap_args}
-    | Lfunction lf ->
-        let s =
-          List.fold_right
-            (fun (id, _) s -> Ident.Map.remove id s)
-            lf.params s
-        in
-        Lfunction {lf with body = subst s lf.body}
-    | Llet(str, k, id, arg, body) ->
-        Llet(str, k, id, subst s arg, subst (Ident.Map.remove id s) body)
-    | Lletrec(decl, body) ->
-        let s =
-          List.fold_left (fun s (id, _) -> Ident.Map.remove id s)
-            s decl
-        in
-        Lletrec(List.map (subst_decl s) decl, subst s body)
-    | Lprim(p, args, loc) -> Lprim(p, subst_list s args, loc)
-    | Lswitch(arg, sw, loc) ->
-        Lswitch(subst s arg,
-                {sw with sw_consts = List.map (subst_case s) sw.sw_consts;
-                        sw_blocks = List.map (subst_case s) sw.sw_blocks;
-                        sw_failaction = subst_opt s sw.sw_failaction; },
-                loc)
-    | Lstringswitch (arg,cases,default,loc) ->
-        Lstringswitch
-          (subst s arg,List.map (subst_strcase s) cases,subst_opt s default,loc)
-    | Lstaticraise (i,args) ->  Lstaticraise (i, subst_list s args)
-    | Lstaticcatch(body, (id, params), handler) ->
-        Lstaticcatch(subst s body, (id, params),
-                    subst (remove_list params s) handler)
-    | Ltrywith(body, exn, handler) ->
-        Ltrywith(subst s body, exn, subst (Ident.Map.remove exn s) handler)
-    | Lifthenelse(e1, e2, e3) -> Lifthenelse(subst s e1, subst s e2, subst s e3)
-    | Lsequence(e1, e2) -> Lsequence(subst s e1, subst s e2)
-    | Lwhile(e1, e2) -> Lwhile(subst s e1, subst s e2)
-    | Lfor(v, lo, hi, dir, body) ->
-        Lfor(v, subst s lo, subst s hi, dir,
-          subst (Ident.Map.remove v s) body)
-    | Lassign(id, e) ->
-        assert(not (Ident.Map.mem id s));
-        Lassign(id, subst s e)
-    | Lsend (k, met, obj, args, loc) ->
-        Lsend (k, subst s met, subst s obj, subst_list s args, loc)
-    | Levent (lam, evt) ->
-        let lev_env =
-          Ident.Map.fold (fun id _ env ->
-            match Env.find_value (Path.Pident id) evt.lev_env with
-            | exception Not_found -> env
-            | vd -> update_env id vd env
-          ) s evt.lev_env
-        in
-        Levent (subst s lam, { evt with lev_env })
-    | Lifused (v, e) -> Lifused (v, subst s e)
-  and subst_list s l = List.map (subst s) l
-  and subst_decl s (id, exp) = (id, subst s exp)
-  and subst_case s (key, case) = (key, subst s case)
-  and subst_strcase s (key, case) = (key, subst s case)
-  and subst_opt s = function
-    | None -> None
-    | Some e -> Some (subst s e)
-  in
-  subst s lam
-
-let rename idmap lam =
-  let update_env oldid vd env =
-    let newid = Ident.Map.find oldid idmap in
-    Env.add_value newid vd env
-  in
-  let s = Ident.Map.map (fun new_id -> Lvar new_id) idmap in
-  subst update_env s lam
-
-let shallow_map f = function
-  | Lvar _
-  | Lconst _ as lam -> lam
-  | Lapply { ap_func; ap_args; ap_loc; ap_should_be_tailcall;
-             ap_inlined; ap_specialised } ->
-      Lapply {
-        ap_func = f ap_func;
-        ap_args = List.map f ap_args;
-        ap_loc;
-        ap_should_be_tailcall;
-        ap_inlined;
-        ap_specialised;
-      }
-  | Lfunction { kind; params; return; body; attr; loc; } ->
-      Lfunction { kind; params; return; body = f body; attr; loc; }
-  | Llet (str, k, v, e1, e2) ->
-      Llet (str, k, v, f e1, f e2)
-  | Lletrec (idel, e2) ->
-      Lletrec (List.map (fun (v, e) -> (v, f e)) idel, f e2)
-  | Lprim (p, el, loc) ->
-      Lprim (p, List.map f el, loc)
-  | Lswitch (e, sw, loc) ->
-      Lswitch (f e,
-               { sw_numconsts = sw.sw_numconsts;
-                 sw_consts = List.map (fun (n, e) -> (n, f e)) sw.sw_consts;
-                 sw_numblocks = sw.sw_numblocks;
-                 sw_blocks = List.map (fun (n, e) -> (n, f e)) sw.sw_blocks;
-                 sw_failaction = Misc.may_map f sw.sw_failaction;
-               },
-               loc)
-  | Lstringswitch (e, sw, default, loc) ->
-      Lstringswitch (
-        f e,
-        List.map (fun (s, e) -> (s, f e)) sw,
-        Misc.may_map f default,
-        loc)
-  | Lstaticraise (i, args) ->
-      Lstaticraise (i, List.map f args)
-  | Lstaticcatch (body, id, handler) ->
-      Lstaticcatch (f body, id, f handler)
-  | Ltrywith (e1, v, e2) ->
-      Ltrywith (f e1, v, f e2)
-  | Lifthenelse (e1, e2, e3) ->
-      Lifthenelse (f e1, f e2, f e3)
-  | Lsequence (e1, e2) ->
-      Lsequence (f e1, f e2)
-  | Lwhile (e1, e2) ->
-      Lwhile (f e1, f e2)
-  | Lfor (v, e1, e2, dir, e3) ->
-      Lfor (v, f e1, f e2, dir, f e3)
-  | Lassign (v, e) ->
-      Lassign (v, f e)
-  | Lsend (k, m, o, el, loc) ->
-      Lsend (k, f m, f o, List.map f el, loc)
-  | Levent (l, ev) ->
-      Levent (f l, ev)
-  | Lifused (v, e) ->
-      Lifused (v, f e)
-
-let map f =
-  let rec g lam = f (shallow_map g lam) in
-  g
-
-(* To let-bind expressions to variables *)
-
-let bind_with_value_kind str (var, kind) exp body =
-  match exp with
-    Lvar var' when Ident.same var var' -> body
-  | _ -> Llet(str, kind, var, exp, body)
-
-let bind str var exp body =
-  bind_with_value_kind str (var, Pgenval) exp body
-
-let negate_integer_comparison = function
-  | Ceq -> Cne
-  | Cne -> Ceq
-  | Clt -> Cge
-  | Cle -> Cgt
-  | Cgt -> Cle
-  | Cge -> Clt
-
-let swap_integer_comparison = function
-  | Ceq -> Ceq
-  | Cne -> Cne
-  | Clt -> Cgt
-  | Cle -> Cge
-  | Cgt -> Clt
-  | Cge -> Cle
-
-let negate_float_comparison = function
-  | CFeq -> CFneq
-  | CFneq -> CFeq
-  | CFlt -> CFnlt
-  | CFnlt -> CFlt
-  | CFgt -> CFngt
-  | CFngt -> CFgt
-  | CFle -> CFnle
-  | CFnle -> CFle
-  | CFge -> CFnge
-  | CFnge -> CFge
-
-let swap_float_comparison = function
-  | CFeq -> CFeq
-  | CFneq -> CFneq
-  | CFlt -> CFgt
-  | CFnlt -> CFngt
-  | CFle -> CFge
-  | CFnle -> CFnge
-  | CFgt -> CFlt
-  | CFngt -> CFnlt
-  | CFge -> CFle
-  | CFnge -> CFnle
-
-let raise_kind = function
-  | Raise_regular -> "raise"
-  | Raise_reraise -> "reraise"
-  | Raise_notrace -> "raise_notrace"
-
-let merge_inline_attributes attr1 attr2 =
-  match attr1, attr2 with
-  | Default_inline, _ -> Some attr2
-  | _, Default_inline -> Some attr1
-  | _, _ ->
-    if attr1 = attr2 then Some attr1
-    else None
-
-let reset () =
-  raise_count := 0
diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
deleted file mode 100644
index 39c7f265ca..0000000000
--- a/bytecomp/lambda.mli
+++ /dev/null
@@ -1,426 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 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.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* The "lambda" intermediate code *)
-
-open Asttypes
-
-type compile_time_constant =
-  | Big_endian
-  | Word_size
-  | Int_size
-  | Max_wosize
-  | Ostype_unix
-  | Ostype_win32
-  | Ostype_cygwin
-  | Backend_type
-
-type immediate_or_pointer =
-  | Immediate
-  | Pointer
-
-type initialization_or_assignment =
-  | Assignment
-  (* Initialization of in heap values, like [caml_initialize] C primitive.  The
-     field should not have been read before and initialization should happen
-     only once. *)
-  | Heap_initialization
-  (* Initialization of roots only. Compiles to a simple store.
-     No checks are done to preserve GC invariants.  *)
-  | Root_initialization
-
-type is_safe =
-  | Safe
-  | Unsafe
-
-type primitive =
-  | Pidentity
-  | Pbytes_to_string
-  | Pbytes_of_string
-  | Pignore
-  | Prevapply
-  | Pdirapply
-    (* Globals *)
-  | Pgetglobal of Ident.t
-  | Psetglobal of Ident.t
-  (* 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 Bigarrays: (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 Bigarray *)
-  | Pbigarraydim of int
-  (* load/set 16,32,64 bits from a string: (unsafe)*)
-  | Pstring_load_16 of bool
-  | Pstring_load_32 of bool
-  | Pstring_load_64 of bool
-  | Pbytes_load_16 of bool
-  | Pbytes_load_32 of bool
-  | Pbytes_load_64 of bool
-  | Pbytes_set_16 of bool
-  | Pbytes_set_32 of bool
-  | Pbytes_set_64 of bool
-  (* load/set 16,32,64 bits from a
-     (char, int8_unsigned_elt, c_layout) Bigarray.Array1.t : (unsafe) *)
-  | Pbigstring_load_16 of bool
-  | Pbigstring_load_32 of bool
-  | Pbigstring_load_64 of bool
-  | Pbigstring_set_16 of bool
-  | Pbigstring_set_32 of bool
-  | Pbigstring_set_64 of bool
-  (* Compile time constants *)
-  | Pctconst of compile_time_constant
-  (* byte swap *)
-  | Pbswap16
-  | Pbbswap of boxed_integer
-  (* Integer to external pointer *)
-  | Pint_as_pointer
-  (* Inhibition of optimisation *)
-  | Popaque
-
-and integer_comparison =
-    Ceq | Cne | Clt | Cgt | Cle | Cge
-
-and float_comparison =
-    CFeq | CFneq | CFlt | CFnlt | CFgt | CFngt | CFle | CFnle | CFge | CFnge
-
-and array_kind =
-    Pgenarray | Paddrarray | Pintarray | Pfloatarray
-
-and value_kind =
-    Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
-
-and block_shape =
-  value_kind list option
-
-and boxed_integer = Primitive.boxed_integer =
-    Pnativeint | Pint32 | Pint64
-
-and 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 =
-    Pbigarray_unknown_layout
-  | Pbigarray_c_layout
-  | Pbigarray_fortran_layout
-
-and raise_kind =
-  | Raise_regular
-  | Raise_reraise
-  | Raise_notrace
-
-val equal_primitive : primitive -> primitive -> bool
-
-val equal_value_kind : value_kind -> value_kind -> bool
-
-val equal_boxed_integer : boxed_integer -> boxed_integer -> bool
-
-type structured_constant =
-    Const_base of constant
-  | Const_pointer of int
-  | Const_block of int * structured_constant list
-  | Const_float_array of string list
-  | Const_immstring of string
-
-type inline_attribute =
-  | Always_inline (* [@inline] or [@inline always] *)
-  | Never_inline (* [@inline never] *)
-  | Unroll of int (* [@unroll x] *)
-  | Default_inline (* no [@inline] attribute *)
-
-val equal_inline_attribute : inline_attribute -> inline_attribute -> bool
-
-type specialise_attribute =
-  | Always_specialise (* [@specialise] or [@specialise always] *)
-  | Never_specialise (* [@specialise never] *)
-  | Default_specialise (* no [@specialise] attribute *)
-
-val equal_specialise_attribute
-   : specialise_attribute
-  -> specialise_attribute
-  -> bool
-
-type local_attribute =
-  | Always_local (* [@local] or [@local always] *)
-  | Never_local (* [@local never] *)
-  | Default_local (* [@local maybe] or no [@local] attribute *)
-
-type function_kind = Curried | Tupled
-
-type let_kind = Strict | Alias | StrictOpt | Variable
-(* Meaning of kinds for let x = e in e':
-    Strict: e may have side-effects; always evaluate e first
-      (If e is a simple expression, e.g. a variable or constant,
-       we may still substitute e'[x/e].)
-    Alias: e is pure, we can substitute e'[x/e] if x has 0 or 1 occurrences
-      in e'
-    StrictOpt: e does not have side-effects, but depend on the store;
-      we can discard e if x does not appear in e'
-    Variable: the variable x is assigned later in e'
- *)
-
-type meth_kind = Self | Public | Cached
-
-val equal_meth_kind : meth_kind -> meth_kind -> bool
-
-type shared_code = (int * int) list     (* stack size -> code label *)
-
-type function_attribute = {
-  inline : inline_attribute;
-  specialise : specialise_attribute;
-  local: local_attribute;
-  is_a_functor: bool;
-  stub: bool;
-}
-
-type lambda =
-    Lvar of Ident.t
-  | Lconst of structured_constant
-  | Lapply of lambda_apply
-  | Lfunction of lfunction
-  | Llet of let_kind * value_kind * Ident.t * lambda * lambda
-  | Lletrec of (Ident.t * lambda) list * lambda
-  | Lprim of primitive * lambda list * Location.t
-  | Lswitch of lambda * lambda_switch * Location.t
-(* switch on strings, clauses are sorted by string order,
-   strings are pairwise distinct *)
-  | Lstringswitch of
-      lambda * (string * lambda) list * lambda option * Location.t
-  | Lstaticraise of int * lambda list
-  | Lstaticcatch of lambda * (int * (Ident.t * value_kind) list) * lambda
-  | Ltrywith of lambda * Ident.t * lambda
-  | Lifthenelse of lambda * lambda * lambda
-  | Lsequence of lambda * lambda
-  | Lwhile of lambda * lambda
-  | Lfor of Ident.t * lambda * lambda * direction_flag * lambda
-  | Lassign of Ident.t * lambda
-  | Lsend of meth_kind * lambda * lambda * lambda list * Location.t
-  | Levent of lambda * lambda_event
-  | Lifused of Ident.t * lambda
-
-and lfunction =
-  { kind: function_kind;
-    params: (Ident.t * value_kind) list;
-    return: value_kind;
-    body: lambda;
-    attr: function_attribute; (* specified with [@inline] attribute *)
-    loc : Location.t; }
-
-and lambda_apply =
-  { ap_func : lambda;
-    ap_args : lambda list;
-    ap_loc : Location.t;
-    ap_should_be_tailcall : bool;       (* true if [@tailcall] was specified *)
-    ap_inlined : inline_attribute; (* specified with the [@inlined] attribute *)
-    ap_specialised : specialise_attribute; }
-
-and lambda_switch =
-  { sw_numconsts: int;                  (* Number of integer cases *)
-    sw_consts: (int * lambda) list;     (* Integer cases *)
-    sw_numblocks: int;                  (* Number of tag block cases *)
-    sw_blocks: (int * lambda) list;     (* Tag block cases *)
-    sw_failaction : lambda option}      (* Action to take if failure *)
-and lambda_event =
-  { lev_loc: Location.t;
-    lev_kind: lambda_event_kind;
-    lev_repr: int ref option;
-    lev_env: Env.t }
-
-and lambda_event_kind =
-    Lev_before
-  | Lev_after of Types.type_expr
-  | Lev_function
-  | Lev_pseudo
-  | Lev_module_definition of Ident.t
-
-type program =
-  { module_ident : Ident.t;
-    main_module_block_size : int;
-    required_globals : Ident.Set.t;    (* Modules whose initializer side effects
-                                          must occur before [code]. *)
-    code : lambda }
-(* Lambda code for the middle-end.
-   * In the closure case the code is a sequence of assignments to a
-     preallocated block of size [main_module_block_size] using
-     (Setfield(Getglobal(module_ident))). The size is used to preallocate
-     the block.
-   * In the flambda case the code is an expression returning a block
-     value of size [main_module_block_size]. The size is used to build
-     the module root as an initialize_symbol
-     Initialize_symbol(module_name, 0,
-       [getfield 0; ...; getfield (main_module_block_size - 1)])
-*)
-
-(* Sharing key *)
-val make_key: lambda -> lambda option
-
-val const_unit: structured_constant
-val lambda_unit: lambda
-val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda
-val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda
-
-val iter_head_constructor: (lambda -> unit) -> lambda -> unit
-(** [iter_head_constructor f lam] apply [f] to only the first level of
-    sub expressions of [lam]. It does not recursively traverse the
-    expression.
-*)
-
-val shallow_iter:
-  tail:(lambda -> unit) ->
-  non_tail:(lambda -> unit) ->
-  lambda -> unit
-(** Same as [iter_head_constructor], but use a different callback for
-    sub-terms which are in tail position or not. *)
-
-val transl_prim: string -> string -> lambda
-(** Translate a value from a persistent module. For instance:
-
-    {[
-      transl_internal_value "CamlinternalLazy" "force"
-    ]}
-*)
-
-val free_variables: lambda -> Ident.Set.t
-
-val transl_module_path: Location.t -> Env.t -> Path.t -> lambda
-val transl_value_path: Location.t -> Env.t -> Path.t -> lambda
-val transl_extension_path: Location.t -> Env.t -> Path.t -> lambda
-val transl_class_path: Location.t -> Env.t -> Path.t -> lambda
-
-val make_sequence: ('a -> lambda) -> 'a list -> lambda
-
-val subst: (Ident.t -> Types.value_description -> Env.t -> Env.t) ->
-  lambda Ident.Map.t -> lambda -> lambda
-(** [subst env_update_fun s lt] applies a substitution [s] to the lambda-term
-    [lt].
-
-    Assumes that the image of the substitution is out of reach
-    of the bound variables of the lambda-term (no capture).
-
-    [env_update_fun] is used to refresh the environment contained in debug
-    events.  *)
-
-val rename : Ident.t Ident.Map.t -> lambda -> lambda
-(** A version of [subst] specialized for the case where we're just renaming
-    idents. *)
-
-val map : (lambda -> lambda) -> lambda -> lambda
-  (** Bottom-up rewriting, applying the function on
-      each node from the leaves to the root. *)
-
-val shallow_map  : (lambda -> lambda) -> lambda -> lambda
-  (** Rewrite each immediate sub-term with the function. *)
-
-val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda
-val bind_with_value_kind:
-  let_kind -> (Ident.t * value_kind) -> lambda -> lambda -> lambda
-
-val negate_integer_comparison : integer_comparison -> integer_comparison
-val swap_integer_comparison : integer_comparison -> integer_comparison
-
-val negate_float_comparison : float_comparison -> float_comparison
-val swap_float_comparison : float_comparison -> float_comparison
-
-val default_function_attribute : function_attribute
-val default_stub_attribute : function_attribute
-
-(***********************)
-(* For static failures *)
-(***********************)
-
-(* Get a new static failure ident *)
-val next_raise_count : unit -> int
-
-val staticfail : lambda (* Anticipated static failure *)
-
-(* Check anticipated failure, substitute its final value *)
-val is_guarded: lambda -> bool
-val patch_guarded : lambda -> lambda -> lambda
-
-val raise_kind: raise_kind -> string
-
-val merge_inline_attributes
-   : inline_attribute
-  -> inline_attribute
-  -> inline_attribute option
-
-val reset: unit -> unit
diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml
deleted file mode 100644
index 0b31ecbc1e..0000000000
--- a/bytecomp/matching.ml
+++ /dev/null
@@ -1,3240 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 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.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Compilation of pattern matching *)
-
-open Misc
-open Asttypes
-open Types
-open Typedtree
-open Lambda
-open Parmatch
-open Printf
-open Printpat
-
-
-let dbg = false
-
-(*  See Peyton-Jones, ``The Implementation of functional programming
-    languages'', chapter 5. *)
-(*
-  Well, it was true at the beginning of the world.
-  Now, see Lefessant-Maranget ``Optimizing Pattern-Matching'' ICFP'2001
-*)
-
-(*
-   Compatibility predicate that considers potential rebindings of constructors
-   of an extension type.
-
-   "may_compat p q" returns false when p and q never admit a common instance;
-   returns true when they may have a common instance.
-*)
-
-module MayCompat =
-  Parmatch.Compat (struct let equal = Types.may_equal_constr end)
-let may_compat = MayCompat.compat
-and may_compats = MayCompat.compats
-
-(*
-   Many functions on the various data structures of the algorithm :
-     - Pattern matrices.
-     - Default environments: mapping from matrices to exit numbers.
-     - Contexts:  matrices whose column are partitioned into
-       left and right.
-     - Jump summaries: mapping from exit numbers to contexts
-*)
-
-
-let string_of_lam lam =
-  Printlambda.lambda Format.str_formatter lam ;
-  Format.flush_str_formatter ()
-
-let all_record_args lbls = match lbls with
-| (_,{lbl_all=lbl_all},_)::_ ->
-    let t =
-      Array.map
-        (fun lbl -> mknoloc (Longident.Lident "?temp?"), lbl,omega)
-        lbl_all in
-    List.iter
-      (fun ((_, lbl,_) as x) ->  t.(lbl.lbl_pos) <- x)
-      lbls ;
-    Array.to_list t
-|  _ -> fatal_error "Parmatch.all_record_args"
-
-type matrix = pattern list list
-
-let add_omega_column pss = List.map (fun ps -> omega::ps) pss
-
-type ctx = {left:pattern list ; right:pattern list}
-
-let pretty_ctx ctx =
-  List.iter
-    (fun {left=left ; right=right} ->
-      Format.eprintf "LEFT:%a RIGHT:%a\n" pretty_line left pretty_line right)
-    ctx
-
-let le_ctx c1 c2 =
-  le_pats c1.left c2.left &&
-  le_pats c1.right c2.right
-
-let lshift {left=left ; right=right} = match right with
-| x::xs -> {left=x::left ; right=xs}
-| _ ->  assert false
-
-let lforget {left=left ; right=right} = match right with
-| _::xs -> {left=omega::left ; right=xs}
-|  _ -> assert false
-
-let rec small_enough n = function
-  | [] -> true
-  | _::rem ->
-      if n <= 0 then false
-      else small_enough (n-1) rem
-
-let ctx_lshift ctx =
-  if small_enough (!Clflags.match_context_rows - 1) ctx then
-    List.map lshift ctx
-  else (* Context pruning *) begin
-    get_mins le_ctx (List.map lforget ctx)
-  end
-
-let  rshift {left=left ; right=right} = match left with
-| p::ps -> {left=ps ; right=p::right}
-| _ -> assert false
-
-let ctx_rshift ctx = List.map rshift ctx
-
-let rec nchars n ps =
-  if n <= 0 then [],ps
-  else match ps with
-  | p::rem ->
-    let chars, cdrs = nchars (n-1) rem in
-    p::chars,cdrs
-  | _ -> assert false
-
-let  rshift_num n {left=left ; right=right} =
-  let shifted,left = nchars n left in
-  {left=left ; right = shifted@right}
-
-let ctx_rshift_num n ctx = List.map (rshift_num n) ctx
-
-(* Recombination of contexts (eg: (_,_)::p1::p2::rem ->  (p1,p2)::rem)
-  All mutable fields are replaced by '_', since side-effects in
-  guards can alter these fields *)
-
-let combine {left=left ; right=right} = match left with
-| p::ps -> {left=ps ; right=set_args_erase_mutable p right}
-| _ -> assert false
-
-let ctx_combine ctx = List.map combine ctx
-
-let ncols = function
-  | [] -> 0
-  | ps::_ -> List.length ps
-
-
-exception NoMatch
-exception OrPat
-
-let filter_matrix matcher pss =
-
-  let rec filter_rec = function
-    | (p::ps)::rem ->
-        begin match p.pat_desc with
-        | Tpat_alias (p,_,_) ->
-            filter_rec ((p::ps)::rem)
-        | Tpat_var _ ->
-            filter_rec ((omega::ps)::rem)
-        | _ ->
-            begin
-              let rem = filter_rec rem in
-              try
-                matcher p ps::rem
-              with
-              | NoMatch -> rem
-              | OrPat   ->
-                match p.pat_desc with
-                | Tpat_or (p1,p2,_) -> filter_rec [(p1::ps) ;(p2::ps)]@rem
-                | _ -> assert false
-            end
-        end
-    | [] -> []
-    | _ ->
-        pretty_matrix Format.err_formatter pss ;
-        fatal_error "Matching.filter_matrix" in
-  filter_rec pss
-
-let make_default matcher env =
-  let rec make_rec = function
-    | [] -> []
-    | ([[]],i)::_ -> [[[]],i]
-    | (pss,i)::rem ->
-        let rem = make_rec rem in
-        match filter_matrix matcher pss with
-        | [] -> rem
-        | ([]::_) -> ([[]],i)::rem
-        | pss -> (pss,i)::rem in
-  make_rec env
-
-let ctx_matcher p =
-  let p = normalize_pat p in
-  match p.pat_desc with
-  | Tpat_construct (_, cstr,omegas) ->
-      (fun q rem -> match q.pat_desc with
-      | Tpat_construct (_, cstr',args)
-(* NB:  may_constr_equal considers (potential) constructor rebinding *)
-        when Types.may_equal_constr cstr cstr' ->
-          p,args@rem
-      | Tpat_any -> p,omegas @ rem
-      | _ -> raise NoMatch)
-  | Tpat_constant cst ->
-      (fun q rem -> match q.pat_desc with
-      | Tpat_constant cst' when const_compare cst cst' = 0 ->
-          p,rem
-      | Tpat_any -> p,rem
-      | _ -> raise NoMatch)
-  | Tpat_variant (lab,Some omega,_) ->
-      (fun q rem -> match q.pat_desc with
-      | Tpat_variant (lab',Some arg,_) when lab=lab' ->
-          p,arg::rem
-      | Tpat_any -> p,omega::rem
-      | _ -> raise NoMatch)
-  | Tpat_variant (lab,None,_) ->
-      (fun q rem -> match q.pat_desc with
-      | Tpat_variant (lab',None,_) when lab=lab' ->
-          p,rem
-      | Tpat_any -> p,rem
-      | _ -> raise NoMatch)
-  | Tpat_array omegas ->
-      let len = List.length omegas in
-      (fun q rem -> match q.pat_desc with
-      | Tpat_array args when List.length args = len -> p,args @ rem
-      | Tpat_any -> p, omegas @ rem
-      | _ -> raise NoMatch)
-  | Tpat_tuple omegas ->
-      let len = List.length omegas  in
-      (fun q rem -> match q.pat_desc with
-      | Tpat_tuple args when List.length args = len -> p,args @ rem
-      | Tpat_any -> p, omegas @ rem
-      | _ -> raise NoMatch)
-  | Tpat_record (((_, lbl, _) :: _) as l,_) -> (* Records are normalized *)
-      let len = Array.length lbl.lbl_all in
-      (fun q rem -> match q.pat_desc with
-      | Tpat_record (((_, lbl', _) :: _) as l',_)
-        when Array.length lbl'.lbl_all = len ->
-          let l' = all_record_args l' in
-          p, List.fold_right (fun (_, _,p) r -> p::r) l' rem
-      | Tpat_any -> p,List.fold_right (fun (_, _,p) r -> p::r) l rem
-      | _ -> raise NoMatch)
-  | Tpat_lazy omega ->
-      (fun q rem -> match q.pat_desc with
-      | Tpat_lazy arg -> p, (arg::rem)
-      | Tpat_any      -> p, (omega::rem)
-      | _             -> raise NoMatch)
- | _ -> fatal_error "Matching.ctx_matcher"
-
-
-
-
-let filter_ctx q ctx =
-
-  let matcher = ctx_matcher q in
-
-  let rec filter_rec = function
-    | ({right=p::ps} as l)::rem ->
-        begin match p.pat_desc with
-        | Tpat_or (p1,p2,_) ->
-            filter_rec ({l with right=p1::ps}::{l with right=p2::ps}::rem)
-        | Tpat_alias (p,_,_) ->
-            filter_rec ({l with right=p::ps}::rem)
-        | Tpat_var _ ->
-            filter_rec ({l with right=omega::ps}::rem)
-        | _ ->
-            begin let rem = filter_rec rem in
-            try
-              let to_left, right = matcher p ps in
-              {left=to_left::l.left ; right=right}::rem
-            with
-            | NoMatch -> rem
-            end
-        end
-    | [] -> []
-    | _ ->  fatal_error "Matching.filter_ctx" in
-
-  filter_rec ctx
-
-let select_columns pss ctx =
-  let n = ncols pss in
-  List.fold_right
-    (fun ps r ->
-      List.fold_right
-        (fun {left=left ; right=right} r ->
-          let transfert, right = nchars n right in
-          try
-            {left = lubs transfert ps @ left ; right=right}::r
-          with
-          | Empty -> r)
-        ctx r)
-    pss []
-
-let ctx_lub p ctx =
-  List.fold_right
-    (fun {left=left ; right=right} r ->
-      match right with
-      | q::rem ->
-          begin try
-            {left=left ; right = lub p q::rem}::r
-          with
-          | Empty -> r
-          end
-      | _ -> fatal_error "Matching.ctx_lub")
-    ctx []
-
-let ctx_match ctx pss =
-  List.exists
-    (fun {right=qs} ->  List.exists (fun ps -> may_compats qs ps)  pss)
-    ctx
-
-type jumps = (int * ctx list) list
-
-let pretty_jumps (env : jumps) = match env with
-| [] -> ()
-| _ ->
-    List.iter
-      (fun (i,ctx) ->
-        Printf.fprintf stderr "jump for %d\n" i ;
-        pretty_ctx ctx)
-      env
-
-
-let rec jumps_extract i = function
-  | [] -> [],[]
-  | (j,pss) as x::rem as all ->
-      if i=j then pss,rem
-      else if j < i then [],all
-      else
-        let r,rem = jumps_extract i rem in
-        r,(x::rem)
-
-let rec jumps_remove i = function
-  | [] -> []
-  | (j,_)::rem when i=j -> rem
-  | x::rem -> x::jumps_remove i rem
-
-let jumps_empty = []
-and jumps_is_empty = function
-  |  [] -> true
-  |  _ -> false
-
-let jumps_singleton i = function
-  | []  -> []
-  | ctx ->  [i,ctx]
-
-let jumps_add i pss jumps = match pss with
-| [] -> jumps
-| _  ->
-    let rec add = function
-      | [] -> [i,pss]
-      | (j,qss) as x::rem as all ->
-          if j > i then x::add rem
-      else if j < i then (i,pss)::all
-      else (i,(get_mins le_ctx (pss@qss)))::rem in
-    add jumps
-
-
-let rec jumps_union (env1:(int*ctx list)list) env2 = match env1,env2 with
-| [],_ -> env2
-| _,[] -> env1
-| ((i1,pss1) as x1::rem1), ((i2,pss2) as x2::rem2) ->
-    if i1=i2 then
-      (i1,get_mins le_ctx (pss1@pss2))::jumps_union rem1 rem2
-    else if i1 > i2 then
-      x1::jumps_union rem1 env2
-    else
-      x2::jumps_union env1 rem2
-
-
-let rec merge = function
-  | env1::env2::rem ->  jumps_union env1 env2::merge rem
-  | envs -> envs
-
-let rec jumps_unions envs = match envs with
-  | [] -> []
-  | [env] -> env
-  | _ -> jumps_unions (merge envs)
-
-let jumps_map f env =
-  List.map
-    (fun (i,pss) -> i,f pss)
-    env
-
-(* Pattern matching before any compilation *)
-
-type pattern_matching =
-  { mutable cases : (pattern list * lambda) list;
-    args : (lambda * let_kind) list ;
-    default : (matrix * int) list}
-
-(* Pattern matching after application of both the or-pat rule and the
-   mixture rule *)
-
-type pm_or_compiled =
-  {body : pattern_matching ;
-   handlers :
-     (matrix * int * (Ident.t * Lambda.value_kind) list * pattern_matching)
-       list;
-   or_matrix : matrix ; }
-
-type pm_half_compiled =
-  | PmOr of pm_or_compiled
-  | PmVar of pm_var_compiled
-  | Pm of pattern_matching
-
-and pm_var_compiled =
-    {inside : pm_half_compiled ; var_arg : lambda ; }
-
-type pm_half_compiled_info =
-    {me : pm_half_compiled ;
-     matrix : matrix ;
-     top_default : (matrix * int) list ; }
-
-let pretty_cases cases =
-  List.iter
-    (fun (ps,_l) ->
-      List.iter
-        (fun p -> Format.eprintf " %a%!" top_pretty p)
-        ps ;
-      Format.eprintf "\n")
-    cases
-
-let pretty_def def =
-  Format.eprintf "+++++ Defaults +++++\n" ;
-  List.iter
-    (fun (pss,i) -> Format.eprintf "Matrix for %d\n%a" i pretty_matrix pss)
-    def ;
-  Format.eprintf "+++++++++++++++++++++\n"
-
-let pretty_pm pm =
-  pretty_cases pm.cases ;
-  if pm.default <> [] then
-    pretty_def pm.default
-
-
-let rec pretty_precompiled = function
-  | Pm pm ->
-      Format.eprintf "++++ PM ++++\n" ;
-      pretty_pm pm
-  | PmVar x ->
-      Format.eprintf "++++ VAR ++++\n" ;
-      pretty_precompiled x.inside
-  | PmOr x ->
-      Format.eprintf "++++ OR ++++\n" ;
-      pretty_pm x.body ;
-      pretty_matrix Format.err_formatter x.or_matrix ;
-      List.iter
-        (fun (_,i,_,pm) ->
-          eprintf "++ Handler %d ++\n" i ;
-          pretty_pm pm)
-        x.handlers
-
-let pretty_precompiled_res first nexts =
-  pretty_precompiled first ;
-  List.iter
-    (fun (e, pmh) ->
-      eprintf "** DEFAULT %d **\n" e ;
-      pretty_precompiled pmh)
-    nexts
-
-
-
-(* Identifying some semantically equivalent lambda-expressions,
-   Our goal here is also to
-   find alpha-equivalent (simple) terms *)
-
-(* However, as shown by PR#6359 such sharing may hinders the
-   lambda-code invariant that all bound idents are unique,
-   when switches are compiled to test sequences.
-   The definitive fix is the systematic introduction of exit/catch
-   in case action sharing is present.
-*)
-
-
-module StoreExp =
-  Switch.Store
-    (struct
-      type t = lambda
-      type key = lambda
-      let compare_key = Stdlib.compare
-      let make_key = Lambda.make_key
-    end)
-
-
-let make_exit i = Lstaticraise (i,[])
-
-(* Introduce a catch, if worth it *)
-let make_catch d k = match d with
-| Lstaticraise (_,[]) -> k d
-| _ ->
-    let e = next_raise_count () in
-    Lstaticcatch (k (make_exit e),(e,[]),d)
-
-(* Introduce a catch, if worth it, delayed version *)
-let rec as_simple_exit = function
-  | Lstaticraise (i,[]) -> Some i
-  | Llet (Alias,_k,_,_,e) -> as_simple_exit e
-  | _ -> None
-
-
-let make_catch_delayed handler = match as_simple_exit handler with
-| Some i -> i,(fun act -> act)
-| None ->
-    let i = next_raise_count () in
-(*
-    Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler);
-*)
-    i,
-    (fun body -> match body with
-    | Lstaticraise (j,_) ->
-        if i=j then handler else body
-    | _ -> Lstaticcatch (body,(i,[]),handler))
-
-
-let raw_action l =
-  match make_key l with | Some l -> l | None -> l
-
-
-let tr_raw act = match make_key act with
-| Some act -> act
-| None -> raise Exit
-
-let same_actions = function
-  | [] -> None
-  | [_,act] -> Some act
-  | (_,act0) :: rem ->
-      try
-        let raw_act0 = tr_raw act0 in
-        let rec s_rec = function
-          | [] -> Some act0
-          | (_,act)::rem ->
-              if raw_act0 = tr_raw act then
-                s_rec rem
-              else
-                None in
-        s_rec rem
-      with
-      | Exit -> None
-
-
-(* Test for swapping two clauses *)
-
-let up_ok_action act1 act2 =
-  try
-    let raw1 = tr_raw act1
-    and raw2 = tr_raw act2 in
-    raw1 = raw2
-  with
-  | Exit -> false
-
-let up_ok (ps,act_p) l =
-  List.for_all
-    (fun (qs,act_q) ->
-      up_ok_action act_p act_q || not (may_compats ps qs))
-    l
-
-(*
-   The simplify function normalizes the first column of the match
-     - records are expanded so that they possess all fields
-     - aliases are removed and replaced by bindings in actions.
-   However or-patterns are simplified differently,
-     - aliases are not removed
-     - or-patterns (_|p) are changed into _
-*)
-
-exception Var of pattern
-
-let simplify_or p =
-  let rec simpl_rec p = match p with
-    | {pat_desc = Tpat_any|Tpat_var _} -> raise (Var p)
-    | {pat_desc = Tpat_alias (q,id,s)} ->
-        begin try
-          {p with pat_desc = Tpat_alias (simpl_rec q,id,s)}
-        with
-        | Var q -> raise (Var {p with pat_desc = Tpat_alias (q,id,s)})
-        end
-    | {pat_desc = Tpat_or (p1,p2,o)} ->
-        let q1 = simpl_rec p1 in
-        begin try
-          let q2 = simpl_rec p2 in
-          {p with pat_desc = Tpat_or (q1, q2, o)}
-        with
-        | Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)})
-        end
-    | {pat_desc = Tpat_record (lbls,closed)} ->
-        let all_lbls = all_record_args lbls in
-        {p with pat_desc=Tpat_record (all_lbls, closed)}
-    | _ -> p in
-  try
-    simpl_rec p
-  with
-  | Var p -> p
-
-let simplify_cases args cls = match args with
-| [] -> assert false
-| (arg,_)::_ ->
-    let rec simplify = function
-      | [] -> []
-      | ((pat :: patl, action) as cl) :: rem ->
-          begin match pat.pat_desc with
-          | Tpat_var (id, _) ->
-              let k = Typeopt.value_kind pat.pat_env pat.pat_type in
-              (omega :: patl, bind_with_value_kind Alias (id, k) arg action) ::
-              simplify rem
-          | Tpat_any ->
-              cl :: simplify rem
-          | Tpat_alias(p, id,_) ->
-              let k = Typeopt.value_kind pat.pat_env pat.pat_type in
-              simplify ((p :: patl,
-                         bind_with_value_kind Alias (id, k) arg action) :: rem)
-          | Tpat_record ([],_) ->
-              (omega :: patl, action)::
-              simplify rem
-          | Tpat_record (lbls, closed) ->
-              let all_lbls = all_record_args lbls in
-              let full_pat =
-                {pat with pat_desc=Tpat_record (all_lbls, closed)} in
-              (full_pat::patl,action)::
-              simplify rem
-          | Tpat_or _ ->
-              let pat_simple  = simplify_or pat in
-              begin match pat_simple.pat_desc with
-              | Tpat_or _ ->
-                  (pat_simple :: patl, action) ::
-                  simplify rem
-              | _ ->
-                  simplify ((pat_simple::patl,action) :: rem)
-              end
-          | _ -> cl :: simplify rem
-          end
-      | _ -> assert false in
-
-    simplify cls
-
-
-
-(* Once matchings are simplified one can easily find
-   their nature *)
-
-let rec what_is_cases cases = match cases with
-| ({pat_desc=Tpat_any} :: _, _) :: rem -> what_is_cases rem
-| (({pat_desc=(Tpat_var _|Tpat_or (_,_,_)|Tpat_alias (_,_,_))}::_),_)::_
-  -> assert false (* applies to simplified matchings only *)
-| (p::_,_)::_ -> p
-| [] -> omega
-| _ -> assert false
-
-
-
-(* A few operations on default environments *)
-let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases)
-
-let cons_default matrix raise_num default =
-  match matrix with
-  | [] -> default
-  | _ -> (matrix,raise_num)::default
-
-let default_compat p def =
-  List.fold_right
-    (fun (pss,i) r ->
-      let qss =
-        List.fold_right
-          (fun qs r -> match qs with
-            | q::rem when may_compat p q -> rem::r
-            | _ -> r)
-          pss [] in
-      match qss with
-      | [] -> r
-      | _  -> (qss,i)::r)
-    def []
-
-(* Or-pattern expansion, variables are a complication w.r.t. the article *)
-
-exception Cannot_flatten
-
-let mk_alpha_env arg aliases ids =
-  List.map
-    (fun id -> id,
-      if List.mem id aliases then
-        match arg with
-        | Some v -> v
-        | _      -> raise Cannot_flatten
-      else
-        Ident.create_local (Ident.name id))
-    ids
-
-let rec explode_or_pat arg patl mk_action rem vars aliases = function
-  | {pat_desc = Tpat_or (p1,p2,_)} ->
-      explode_or_pat
-        arg patl mk_action
-        (explode_or_pat arg patl mk_action rem vars aliases p2)
-        vars aliases p1
-  | {pat_desc = Tpat_alias (p,id, _)} ->
-      explode_or_pat arg patl mk_action rem vars (id::aliases) p
-  | {pat_desc = Tpat_var (x, _)} ->
-      let env = mk_alpha_env arg (x::aliases) vars in
-      (omega::patl,mk_action (List.map snd env))::rem
-  | p ->
-      let env = mk_alpha_env arg aliases vars in
-      (alpha_pat env p::patl,mk_action (List.map snd env))::rem
-
-let pm_free_variables {cases=cases} =
-  List.fold_right
-    (fun (_,act) r -> Ident.Set.union (free_variables act) r)
-    cases Ident.Set.empty
-
-
-(* Basic grouping predicates *)
-let pat_as_constr = function
-  | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr
-  | _ -> fatal_error "Matching.pat_as_constr"
-
-let group_const_int = function
-  | {pat_desc= Tpat_constant Const_int _ } -> true
-  | _                                      -> false
-
-let group_const_char = function
-  | {pat_desc= Tpat_constant Const_char _ } -> true
-  | _                                      -> false
-
-let group_const_string = function
-  | {pat_desc= Tpat_constant Const_string _ } -> true
-  | _                                      -> false
-
-let group_const_float = function
-  | {pat_desc= Tpat_constant Const_float _ } -> true
-  | _                                      -> false
-
-let group_const_int32 = function
-  | {pat_desc= Tpat_constant Const_int32 _ } -> true
-  | _                                      -> false
-
-let group_const_int64 = function
-  | {pat_desc= Tpat_constant Const_int64 _ } -> true
-  | _                                      -> false
-
-let group_const_nativeint = function
-  | {pat_desc= Tpat_constant Const_nativeint _ } -> true
-  | _                                      -> false
-
-and group_constructor = function
-  | {pat_desc = Tpat_construct (_,_,_)} -> true
-  | _ -> false
-
-and group_variant = function
-  | {pat_desc = Tpat_variant (_, _, _)} -> true
-  | _ -> false
-
-and group_var = function
-  | {pat_desc=Tpat_any} -> true
-  | _ -> false
-
-and group_tuple = function
-  | {pat_desc = (Tpat_tuple _|Tpat_any)} -> true
-  | _ -> false
-
-and group_record = function
-  | {pat_desc = (Tpat_record _|Tpat_any)} -> true
-  | _ -> false
-
-and group_array = function
-  | {pat_desc=Tpat_array _} -> true
-  | _ -> false
-
-and group_lazy = function
-  | {pat_desc = Tpat_lazy _} -> true
-  | _ -> false
-
-let get_group p = match p.pat_desc with
-| Tpat_any -> group_var
-| Tpat_constant Const_int _ -> group_const_int
-| Tpat_constant Const_char _ -> group_const_char
-| Tpat_constant Const_string _ -> group_const_string
-| Tpat_constant Const_float _ -> group_const_float
-| Tpat_constant Const_int32 _ -> group_const_int32
-| Tpat_constant Const_int64 _ -> group_const_int64
-| Tpat_constant Const_nativeint _ -> group_const_nativeint
-| Tpat_construct _ -> group_constructor
-| Tpat_tuple _ -> group_tuple
-| Tpat_record _ -> group_record
-| Tpat_array _ -> group_array
-| Tpat_variant (_,_,_) -> group_variant
-| Tpat_lazy _ -> group_lazy
-|  _ -> fatal_error "Matching.get_group"
-
-
-
-let is_or p = match p.pat_desc with
-| Tpat_or _ -> true
-| _ -> false
-
-(* Conditions for appending to the Or matrix *)
-let conda p q = not (may_compat p q)
-and condb act ps qs =  not (is_guarded act) && Parmatch.le_pats qs ps
-
-let or_ok p ps l =
-  List.for_all
-    (function
-      | ({pat_desc=Tpat_or _} as q::qs,act) ->
-          conda p q || condb act ps qs
-      | _ -> true)
-    l
-
-(* Insert or append a pattern in the Or matrix *)
-
-let equiv_pat p q = le_pat p q && le_pat q p
-
-let rec get_equiv p l = match l with
-  | (q::_,_) as cl::rem ->
-      if equiv_pat p q then
-        let others,rem = get_equiv p rem in
-        cl::others,rem
-      else
-        [],l
-  | _ -> [],l
-
-
-let insert_or_append p ps act ors no =
-  let rec attempt seen = function
-    | (q::qs,act_q) as cl::rem ->
-        if is_or q then begin
-          if may_compat p q then
-            if
-              Typedtree.pat_bound_idents p = [] &&
-              Typedtree.pat_bound_idents q = [] &&
-              equiv_pat p q
-            then (* attempt insert, for equivalent orpats with no variables *)
-              let _, not_e = get_equiv q rem in
-              if
-                or_ok p ps not_e && (* check append condition for head of O *)
-                List.for_all        (* check insert condition for tail of O *)
-                  (fun cl -> match cl with
-                  | (q::_,_) -> not (may_compat p q)
-                  | _        -> assert false)
-                  seen
-              then (* insert *)
-                List.rev_append seen ((p::ps,act)::cl::rem), no
-              else (* fail to insert or append *)
-                ors,(p::ps,act)::no
-            else if condb act_q ps qs then (* check condition (b) for append *)
-              attempt (cl::seen) rem
-            else
-              ors,(p::ps,act)::no
-          else (* p # q, go on with append/insert *)
-            attempt (cl::seen) rem
-        end else (* q is not an or-pat, go on with append/insert *)
-          attempt (cl::seen) rem
-    | _  -> (* [] in fact *)
-        (p::ps,act)::ors,no in (* success in appending *)
-  attempt [] ors
-
-(* Reconstruct default information from half_compiled  pm list *)
-
-let rec rebuild_matrix pmh = match pmh with
-  | Pm pm -> as_matrix pm.cases
-  | PmOr {or_matrix=m} -> m
-  | PmVar x -> add_omega_column  (rebuild_matrix x.inside)
-
-let rec rebuild_default nexts def = match nexts with
-| [] -> def
-| (e, pmh)::rem ->
-    (add_omega_column (rebuild_matrix pmh), e)::
-    rebuild_default rem def
-
-let rebuild_nexts arg nexts k =
-  List.fold_right
-    (fun (e, pm) k -> (e, PmVar {inside=pm ; var_arg=arg})::k)
-    nexts k
-
-
-(*
-  Split a matching.
-    Splitting is first directed by or-patterns, then by
-    tests (e.g. constructors)/variable transitions.
-
-    The approach is greedy, every split function attempts to
-    raise rows as much as possible in the top matrix,
-    then splitting applies again to the remaining rows.
-
-    Some precompilation of or-patterns and
-    variable pattern occurs. Mostly this means that bindings
-    are performed now,  being replaced by let-bindings
-    in actions (cf. simplify_cases).
-
-    Additionally, if the match argument is a variable, matchings whose
-    first column is made of variables only are split further
-    (cf. precompile_var).
-
-*)
-
-
-let rec split_or argo cls args def =
-
-  let cls = simplify_cases args cls in
-
-  let rec do_split before ors no = function
-    | [] ->
-        cons_next
-          (List.rev before) (List.rev ors) (List.rev no)
-    | ((p::ps,act) as cl)::rem ->
-        if up_ok cl no then
-          if is_or p then
-            let ors, no = insert_or_append p ps act ors no in
-            do_split before ors no rem
-          else begin
-            if up_ok cl ors then
-              do_split (cl::before) ors no rem
-            else if or_ok p ps ors then
-              do_split before (cl::ors) no rem
-            else
-              do_split before ors (cl::no) rem
-          end
-        else
-          do_split before ors (cl::no) rem
-    | _ -> assert false
-
-  and cons_next yes yesor = function
-    | [] ->
-        precompile_or argo yes yesor args def []
-    | rem ->
-        let {me=next ; matrix=matrix ; top_default=def},nexts =
-          do_split [] [] [] rem in
-        let idef = next_raise_count () in
-        precompile_or
-          argo yes yesor args
-          (cons_default matrix idef def)
-          ((idef,next)::nexts) in
-
-  do_split [] [] [] cls
-
-(* Ultra-naive splitting, close to semantics, used for extension,
-   as potential rebind prevents any kind of optimisation *)
-
-and split_naive cls args def k =
-
-  let rec split_exc cstr0 yes = function
-    | [] ->
-        let yes = List.rev yes in
-        { me = Pm {cases=yes; args=args; default=def;} ;
-          matrix = as_matrix yes ;
-          top_default=def},
-        k
-    | (p::_,_ as cl)::rem ->
-        if group_constructor p then
-          let cstr = pat_as_constr p in
-          if cstr = cstr0 then split_exc cstr0 (cl::yes) rem
-          else
-            let yes = List.rev yes in
-            let {me=next ; matrix=matrix ; top_default=def}, nexts =
-              split_exc cstr [cl] rem in
-            let idef = next_raise_count () in
-            let def = cons_default matrix idef def in
-            { me = Pm {cases=yes; args=args; default=def} ;
-              matrix = as_matrix yes ;
-              top_default = def; },
-            (idef,next)::nexts
-        else
-          let yes = List.rev yes in
-          let {me=next ; matrix=matrix ; top_default=def}, nexts =
-              split_noexc [cl] rem in
-            let idef = next_raise_count () in
-            let def = cons_default matrix idef def in
-            { me = Pm {cases=yes; args=args; default=def} ;
-              matrix = as_matrix yes ;
-              top_default = def; },
-            (idef,next)::nexts
-    | _ -> assert false
-
-  and split_noexc yes = function
-    | [] -> precompile_var args (List.rev yes) def k
-    | (p::_,_ as cl)::rem ->
-        if group_constructor p then
-          let yes= List.rev yes in
-          let {me=next; matrix=matrix; top_default=def;},nexts =
-            split_exc (pat_as_constr p) [cl] rem in
-          let idef = next_raise_count () in
-          precompile_var
-            args yes
-            (cons_default matrix idef def)
-            ((idef,next)::nexts)
-        else split_noexc (cl::yes) rem
-    | _ -> assert false in
-
-  match cls with
-  | [] -> assert false
-  | (p::_,_ as cl)::rem ->
-      if group_constructor p then
-        split_exc (pat_as_constr p) [cl] rem
-      else
-        split_noexc [cl] rem
-  | _ -> assert false
-
-and split_constr cls args def k =
-  let ex_pat = what_is_cases cls in
-  match ex_pat.pat_desc with
-  | Tpat_any -> precompile_var args cls def k
-  | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) ->
-      split_naive cls args def k
-  | _ ->
-
-      let group = get_group ex_pat in
-
-      let rec split_ex yes no = function
-        | [] ->
-            let yes = List.rev yes and no = List.rev no in
-            begin match no with
-            | [] ->
-                {me = Pm {cases=yes ; args=args ; default=def} ;
-                  matrix = as_matrix yes ;
-                  top_default = def},
-                k
-            | cl::rem ->
-                begin match yes with
-                | [] ->
-                    (* Could not success in raising up a constr matching up *)
-                    split_noex [cl] [] rem
-                | _ ->
-                    let {me=next ; matrix=matrix ; top_default=def}, nexts =
-                      split_noex [cl] [] rem in
-                    let idef = next_raise_count () in
-                    let def = cons_default matrix idef def in
-                    {me = Pm {cases=yes ; args=args ; default=def} ;
-                      matrix = as_matrix yes ;
-                      top_default = def },
-                    (idef, next)::nexts
-                end
-            end
-        | (p::_,_) as cl::rem ->
-            if group p && up_ok cl no then
-              split_ex (cl::yes) no rem
-            else
-              split_ex yes (cl::no) rem
-        | _ -> assert false
-
-      and split_noex yes no = function
-        | [] ->
-            let yes = List.rev yes and no = List.rev no in
-            begin match no with
-            | [] -> precompile_var args yes def k
-            | cl::rem ->
-                let {me=next ; matrix=matrix ; top_default=def}, nexts =
-                  split_ex [cl] [] rem in
-                let idef = next_raise_count () in
-                precompile_var
-                  args yes
-                  (cons_default matrix idef def)
-                  ((idef,next)::nexts)
-            end
-        | [ps,_ as cl]
-            when List.for_all group_var ps && yes <> [] ->
-       (* This enables an extra division in some frequent cases :
-          last row is made of variables only *)
-              split_noex yes (cl::no) []
-        | (p::_,_) as cl::rem ->
-            if not (group p) && up_ok cl no then
-              split_noex (cl::yes) no rem
-            else
-              split_noex yes (cl::no) rem
-        | _ -> assert false in
-
-      match cls with
-      | ((p::_,_) as cl)::rem ->
-          if group p then split_ex [cl] [] rem
-          else split_noex [cl] [] rem
-      | _ ->  assert false
-
-and precompile_var  args cls def k = match args with
-| []  -> assert false
-| _::((Lvar v as av,_) as arg)::rargs ->
-    begin match cls with
-    | [_] -> (* as split as it can *)
-        dont_precompile_var args cls def k
-    | _ ->
-(* Precompile *)
-        let var_cls =
-          List.map
-            (fun (ps,act) -> match ps with
-            | _::ps -> ps,act | _     -> assert false)
-            cls
-        and var_def = make_default (fun _ rem -> rem) def in
-        let {me=first ; matrix=matrix}, nexts =
-          split_or (Some v) var_cls (arg::rargs) var_def in
-
-(* Compute top information *)
-        match nexts with
-        | [] -> (* If you need *)
-            dont_precompile_var args cls def k
-        | _  ->
-            let rfirst =
-              {me = PmVar {inside=first ; var_arg = av} ;
-                matrix = add_omega_column matrix ;
-                top_default = rebuild_default nexts def ; }
-            and rnexts = rebuild_nexts av nexts k in
-            rfirst, rnexts
-    end
-|  _ ->
-    dont_precompile_var args cls def k
-
-and dont_precompile_var args cls def k =
-  {me =  Pm {cases = cls ; args = args ; default = def } ;
-    matrix=as_matrix cls ;
-    top_default=def},k
-
-and precompile_or argo cls ors args def k = match ors with
-| [] -> split_constr cls args def k
-| _  ->
-    let rec do_cases = function
-      | ({pat_desc=Tpat_or _} as orp::patl, action)::rem ->
-          let others,rem = get_equiv orp rem in
-          let orpm =
-            {cases =
-              (patl, action)::
-              List.map
-                (function
-                  | (_::ps,action) -> ps,action
-                  | _ -> assert false)
-                others ;
-              args = (match args with _::r -> r | _ -> assert false) ;
-             default = default_compat orp def} in
-          let pm_fv = pm_free_variables orpm in
-          let vars =
-            Typedtree.pat_bound_idents_full orp
-            |> List.filter (fun (id, _, _) -> Ident.Set.mem id pm_fv)
-            |> List.map (fun (id,_,ty) -> id,Typeopt.value_kind orp.pat_env ty)
-          in
-          let or_num = next_raise_count () in
-          let new_patl = Parmatch.omega_list patl in
-
-          let mk_new_action vs =
-            Lstaticraise
-              (or_num, List.map (fun v -> Lvar v) vs) in
-
-          let body,handlers = do_cases rem in
-          explode_or_pat
-            argo new_patl mk_new_action body (List.map fst vars) [] orp,
-          let mat = [[orp]] in
-          ((mat, or_num, vars , orpm):: handlers)
-      | cl::rem ->
-          let new_ord,new_to_catch = do_cases rem in
-          cl::new_ord,new_to_catch
-      | [] -> [],[] in
-
-    let end_body, handlers = do_cases ors in
-    let matrix = as_matrix (cls@ors)
-    and body = {cases=cls@end_body ; args=args ; default=def} in
-    {me = PmOr {body=body ; handlers=handlers ; or_matrix=matrix} ;
-      matrix=matrix ;
-      top_default=def},
-    k
-
-let split_precompile argo pm =
-  let {me=next}, nexts = split_or argo pm.cases pm.args pm.default  in
-  if dbg && (nexts <> [] || (match next with PmOr _ -> true | _ -> false))
-  then begin
-    Format.eprintf "** SPLIT **\n" ;
-    pretty_pm pm ;
-    pretty_precompiled_res  next nexts
-  end ;
-  next, nexts
-
-
-(* General divide functions *)
-
-let add_line patl_action pm = pm.cases <- patl_action :: pm.cases; pm
-
-type cell =
-  {pm : pattern_matching ;
-  ctx : ctx list ;
-  pat : pattern}
-
-let add make_matching_fun division eq_key key patl_action args =
-  try
-    let (_,cell) = List.find (fun (k,_) -> eq_key key k) division in
-    cell.pm.cases <- patl_action :: cell.pm.cases;
-    division
-  with Not_found ->
-    let cell = make_matching_fun args in
-    cell.pm.cases <- [patl_action] ;
-    (key, cell) :: division
-
-
-let divide make eq_key get_key get_args ctx pm =
-
-  let rec divide_rec = function
-    | (p::patl,action) :: rem ->
-        let this_match = divide_rec rem in
-        add
-          (make p pm.default ctx)
-          this_match eq_key (get_key p) (get_args p patl,action) pm.args
-    | _ -> [] in
-
-  divide_rec pm.cases
-
-
-let divide_line make_ctx make get_args pat ctx pm =
-  let rec divide_rec = function
-    | (p::patl,action) :: rem ->
-        let this_match = divide_rec rem in
-        add_line (get_args p patl, action) this_match
-    | _ -> make pm.default pm.args in
-
-  {pm = divide_rec pm.cases ;
-  ctx=make_ctx ctx ;
-  pat=pat}
-
-
-
-(* Then come various functions,
-   There is one set of functions per matching style
-   (constants, constructors etc.)
-
-   - matcher functions are arguments to make_default (for default handlers)
-   They may raise NoMatch or OrPat and perform the full
-   matching (selection + arguments).
-
-
-   - get_args and get_key are for the compiled matrices, note that
-   selection and getting arguments are separated.
-
-   - make_ _matching combines the previous functions for producing
-   new  ``pattern_matching'' records.
-*)
-
-
-
-let rec matcher_const cst p rem = match p.pat_desc with
-| Tpat_or (p1,p2,_) ->
-    begin try
-      matcher_const cst p1 rem with
-    | NoMatch -> matcher_const cst p2 rem
-    end
-| Tpat_constant c1 when const_compare c1 cst = 0 -> rem
-| Tpat_any    -> rem
-| _ -> raise NoMatch
-
-let get_key_constant caller = function
-  | {pat_desc= Tpat_constant cst} -> cst
-  | p ->
-      Format.eprintf "BAD: %s" caller ;
-      pretty_pat p ;
-      assert false
-
-let get_args_constant _ rem = rem
-
-let make_constant_matching p def ctx = function
-    [] -> fatal_error "Matching.make_constant_matching"
-  | (_ :: argl) ->
-      let def =
-        make_default
-          (matcher_const (get_key_constant "make" p)) def
-      and ctx =
-        filter_ctx p  ctx in
-      {pm = {cases = []; args = argl ; default = def} ;
-        ctx = ctx ;
-        pat = normalize_pat p}
-
-
-
-
-let divide_constant ctx m =
-  divide
-    make_constant_matching
-    (fun c d -> const_compare c d = 0) (get_key_constant "divide")
-    get_args_constant
-    ctx m
-
-(* Matching against a constructor *)
-
-
-let make_field_args loc binding_kind arg first_pos last_pos argl =
-  let rec make_args pos =
-    if pos > last_pos
-    then argl
-    else (Lprim(Pfield pos, [arg], loc), binding_kind) :: make_args (pos + 1)
-  in make_args first_pos
-
-let get_key_constr = function
-  | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr.cstr_tag
-  | _ -> assert false
-
-let get_args_constr p rem = match p with
-| {pat_desc=Tpat_construct (_, _, args)} -> args @ rem
-| _ -> assert false
-
-(* NB: matcher_constr applies to default matrices.
-
-       In that context, matching by constructors of extensible
-       types degrades to arity checking, due to potential rebinding.
-       This comparison is performed by Types.may_equal_constr.
-*)
-
-let matcher_constr cstr = match cstr.cstr_arity with
-| 0 ->
-    let rec matcher_rec q rem = match q.pat_desc with
-    | Tpat_or (p1,p2,_) ->
-        begin
-          try matcher_rec p1 rem
-          with NoMatch -> matcher_rec p2 rem
-        end
-    | Tpat_construct (_, cstr',[])
-      when Types.may_equal_constr cstr cstr' -> rem
-    | Tpat_any -> rem
-    | _ -> raise NoMatch in
-    matcher_rec
-| 1 ->
-    let rec matcher_rec q rem = match q.pat_desc with
-    | Tpat_or (p1,p2,_) ->
-        let r1 = try Some (matcher_rec p1 rem) with NoMatch -> None
-        and r2 = try Some (matcher_rec p2 rem) with NoMatch -> None in
-        begin match r1,r2 with
-        | None, None -> raise NoMatch
-        | Some r1, None -> r1
-        | None, Some r2 -> r2
-        | Some (a1::_), Some (a2::_) ->
-            {a1 with
-             pat_loc = Location.none ;
-             pat_desc = Tpat_or (a1, a2, None)}::
-            rem
-        | _, _ -> assert false
-        end
-    | Tpat_construct (_, cstr', [arg])
-      when Types.may_equal_constr cstr cstr' -> arg::rem
-    | Tpat_any -> omega::rem
-    | _ -> raise NoMatch in
-    matcher_rec
-| _ ->
-    fun q rem -> match q.pat_desc with
-    | Tpat_or (_,_,_) -> raise OrPat
-    | Tpat_construct (_,cstr',args)
-      when  Types.may_equal_constr cstr cstr' -> args @ rem
-    | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem
-    | _        -> raise NoMatch
-
-let make_constr_matching p def ctx = function
-    [] -> fatal_error "Matching.make_constr_matching"
-  | ((arg, _mut) :: argl) ->
-      let cstr = pat_as_constr p in
-      let newargs =
-        if cstr.cstr_inlined <> None then
-          (arg, Alias) :: argl
-        else match cstr.cstr_tag with
-          Cstr_constant _ | Cstr_block _ ->
-            make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl
-        | Cstr_unboxed -> (arg, Alias) :: argl
-        | Cstr_extension _ ->
-            make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl in
-      {pm=
-        {cases = []; args = newargs;
-          default = make_default (matcher_constr cstr) def} ;
-        ctx =  filter_ctx p ctx ;
-        pat=normalize_pat p}
-
-
-let divide_constructor ctx pm =
-  divide
-    make_constr_matching
-    (=) get_key_constr get_args_constr
-    ctx pm
-
-(* Matching against a variant *)
-
-let rec matcher_variant_const lab p rem = match p.pat_desc with
-| Tpat_or (p1, p2, _) ->
-    begin
-      try
-        matcher_variant_const lab p1 rem
-      with
-      | NoMatch -> matcher_variant_const lab p2 rem
-    end
-| Tpat_variant (lab1,_,_) when lab1=lab -> rem
-| Tpat_any -> rem
-| _   -> raise NoMatch
-
-
-let make_variant_matching_constant p lab def ctx = function
-    [] -> fatal_error "Matching.make_variant_matching_constant"
-  | (_ :: argl) ->
-      let def = make_default (matcher_variant_const lab) def
-      and ctx = filter_ctx p ctx in
-      {pm={ cases = []; args = argl ; default=def} ;
-        ctx=ctx ;
-        pat = normalize_pat p}
-
-let matcher_variant_nonconst lab p rem = match p.pat_desc with
-| Tpat_or (_,_,_) -> raise OrPat
-| Tpat_variant (lab1,Some arg,_) when lab1=lab -> arg::rem
-| Tpat_any -> omega::rem
-| _   -> raise NoMatch
-
-
-let make_variant_matching_nonconst p lab def ctx = function
-    [] -> fatal_error "Matching.make_variant_matching_nonconst"
-  | ((arg, _mut) :: argl) ->
-      let def = make_default (matcher_variant_nonconst lab) def
-      and ctx = filter_ctx p ctx in
-      {pm=
-        {cases = []; args = (Lprim(Pfield 1, [arg], p.pat_loc), Alias) :: argl;
-          default=def} ;
-        ctx=ctx ;
-        pat = normalize_pat p}
-
-let divide_variant row ctx {cases = cl; args = al; default=def} =
-  let row = Btype.row_repr row in
-  let rec divide = function
-      ({pat_desc = Tpat_variant(lab, pato, _)} as p:: patl, action) :: rem ->
-        let variants = divide rem in
-        if try Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent
-        with Not_found -> true
-        then
-          variants
-        else begin
-          let tag = Btype.hash_variant lab in
-          match pato with
-            None ->
-              add (make_variant_matching_constant p lab def ctx) variants
-                (=) (Cstr_constant tag) (patl, action) al
-          | Some pat ->
-              add (make_variant_matching_nonconst p lab def ctx) variants
-                (=) (Cstr_block tag) (pat :: patl, action) al
-        end
-    | _ -> []
-  in
-  divide cl
-
-(*
-  Three ``no-test'' cases
-  *)
-
-(* Matching against a variable *)
-
-let get_args_var _ rem = rem
-
-
-let make_var_matching def = function
-  | [] ->  fatal_error "Matching.make_var_matching"
-  | _::argl ->
-      {cases=[] ;
-        args = argl ;
-        default= make_default get_args_var def}
-
-let divide_var ctx pm =
-  divide_line ctx_lshift make_var_matching get_args_var omega ctx pm
-
-(* Matching and forcing a lazy value *)
-
-let get_arg_lazy p rem = match p with
-| {pat_desc = Tpat_any} -> omega :: rem
-| {pat_desc = Tpat_lazy arg} -> arg :: rem
-| _ ->  assert false
-
-let matcher_lazy p rem = match p.pat_desc with
-| Tpat_or (_,_,_)     -> raise OrPat
-| Tpat_any
-| Tpat_var _          -> omega :: rem
-| Tpat_lazy arg       -> arg :: rem
-| _                   -> raise NoMatch
-
-(* Inlining the tag tests before calling the primitive that works on
-   lazy blocks. This is also used in translcore.ml.
-   No other call than Obj.tag when the value has been forced before.
-*)
-
-let prim_obj_tag =
-  Primitive.simple ~name:"caml_obj_tag" ~arity:1 ~alloc:false
-
-let get_mod_field modname field =
-  lazy (
-    let mod_ident = Ident.create_persistent modname in
-    let env = Env.add_persistent_structure mod_ident Env.initial_safe_string in
-    match Env.open_pers_signature modname env with
-    | exception Not_found -> fatal_error ("Module "^modname^" unavailable.")
-    | env -> begin
-        match Env.lookup_value (Longident.Lident field) env with
-        | exception Not_found ->
-            fatal_error ("Primitive "^modname^"."^field^" not found.")
-        | (path, _) -> transl_value_path Location.none env path
-      end
-  )
-
-let code_force_lazy_block =
-  get_mod_field "CamlinternalLazy" "force_lazy_block"
-let code_force_lazy =
-  get_mod_field "CamlinternalLazy" "force"
-;;
-
-(* inline_lazy_force inlines the beginning of the code of Lazy.force. When
-   the value argument is tagged as:
-   - forward, take field 0
-   - lazy, call the primitive that forces (without testing again the tag)
-   - anything else, return it
-
-   Using Lswitch below relies on the fact that the GC does not shortcut
-   Forward(val_out_of_heap).
-*)
-
-let inline_lazy_force_cond arg loc =
-  let idarg = Ident.create_local "lzarg" in
-  let varg = Lvar idarg in
-  let tag = Ident.create_local "tag" in
-  let force_fun = Lazy.force code_force_lazy_block in
-  Llet(Strict, Pgenval, idarg, arg,
-       Llet(Alias, Pgenval, tag, Lprim(Pccall prim_obj_tag, [varg], loc),
-            Lifthenelse(
-              (* if (tag == Obj.forward_tag) then varg.(0) else ... *)
-              Lprim(Pintcomp Ceq,
-                    [Lvar tag; Lconst(Const_base(Const_int Obj.forward_tag))],
-                    loc),
-              Lprim(Pfield 0, [varg], loc),
-              Lifthenelse(
-                (* ... if (tag == Obj.lazy_tag) then Lazy.force varg else ... *)
-                Lprim(Pintcomp Ceq,
-                      [Lvar tag; Lconst(Const_base(Const_int Obj.lazy_tag))],
-                      loc),
-                Lapply{ap_should_be_tailcall=false;
-                       ap_loc=loc;
-                       ap_func=force_fun;
-                       ap_args=[varg];
-                       ap_inlined=Default_inline;
-                       ap_specialised=Default_specialise},
-                (* ... arg *)
-                  varg))))
-
-let inline_lazy_force_switch arg loc =
-  let idarg = Ident.create_local "lzarg" in
-  let varg = Lvar idarg in
-  let force_fun = Lazy.force code_force_lazy_block in
-  Llet(Strict, Pgenval, idarg, arg,
-       Lifthenelse(
-         Lprim(Pisint, [varg], loc), varg,
-         (Lswitch
-            (varg,
-             { sw_numconsts = 0; sw_consts = [];
-               sw_numblocks = 256;  (* PR#6033 - tag ranges from 0 to 255 *)
-               sw_blocks =
-                 [ (Obj.forward_tag, Lprim(Pfield 0, [varg], loc));
-                   (Obj.lazy_tag,
-                    Lapply{ap_should_be_tailcall=false;
-                           ap_loc=loc;
-                           ap_func=force_fun;
-                           ap_args=[varg];
-                           ap_inlined=Default_inline;
-                           ap_specialised=Default_specialise}) ];
-               sw_failaction = Some varg }, loc ))))
-
-let inline_lazy_force arg loc =
-  if !Clflags.afl_instrument then
-    (* Disable inlining optimisation if AFL instrumentation active,
-       so that the GC forwarding optimisation is not visible in the
-       instrumentation output.
-       (see https://github.com/stedolan/crowbar/issues/14) *)
-    Lapply{ap_should_be_tailcall = false;
-           ap_loc=loc;
-           ap_func=Lazy.force code_force_lazy;
-           ap_args=[arg];
-           ap_inlined=Default_inline;
-           ap_specialised=Default_specialise}
-  else
-    if !Clflags.native_code then
-      (* Lswitch generates compact and efficient native code *)
-      inline_lazy_force_switch arg loc
-    else
-      (* generating bytecode: Lswitch would generate too many rather big
-         tables (~ 250 elts); conditionals are better *)
-      inline_lazy_force_cond arg loc
-
-let make_lazy_matching def = function
-    [] -> fatal_error "Matching.make_lazy_matching"
-  | (arg,_mut) :: argl ->
-      { cases = [];
-        args =
-          (inline_lazy_force arg Location.none, Strict) :: argl;
-        default = make_default matcher_lazy def }
-
-let divide_lazy p ctx pm =
-  divide_line
-    (filter_ctx p)
-    make_lazy_matching
-    get_arg_lazy
-    p ctx pm
-
-(* Matching against a tuple pattern *)
-
-
-let get_args_tuple arity p rem = match p with
-| {pat_desc = Tpat_any} -> omegas arity @ rem
-| {pat_desc = Tpat_tuple args} ->
-    args @ rem
-| _ ->  assert false
-
-let matcher_tuple arity p rem = match p.pat_desc with
-| Tpat_or (_,_,_)     -> raise OrPat
-| Tpat_any
-| Tpat_var _ -> omegas arity @ rem
-| Tpat_tuple args when List.length args = arity -> args @ rem
-| _ ->  raise NoMatch
-
-let make_tuple_matching loc arity def = function
-    [] -> fatal_error "Matching.make_tuple_matching"
-  | (arg, _mut) :: argl ->
-      let rec make_args pos =
-        if pos >= arity
-        then argl
-        else (Lprim(Pfield pos, [arg], loc), Alias) :: make_args (pos + 1) in
-      {cases = []; args = make_args 0 ;
-        default=make_default (matcher_tuple arity) def}
-
-
-let divide_tuple arity p ctx pm =
-  divide_line
-    (filter_ctx p)
-    (make_tuple_matching p.pat_loc arity)
-    (get_args_tuple  arity) p ctx pm
-
-(* Matching against a record pattern *)
-
-
-let record_matching_line num_fields lbl_pat_list =
-  let patv = Array.make num_fields omega in
-  List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list;
-  Array.to_list patv
-
-let get_args_record num_fields p rem = match p with
-| {pat_desc=Tpat_any} ->
-    record_matching_line num_fields [] @ rem
-| {pat_desc=Tpat_record (lbl_pat_list,_)} ->
-    record_matching_line num_fields lbl_pat_list @ rem
-| _ -> assert false
-
-let matcher_record num_fields p rem = match p.pat_desc with
-| Tpat_or (_,_,_) -> raise OrPat
-| Tpat_any
-| Tpat_var _      ->
-  record_matching_line num_fields [] @ rem
-| Tpat_record ([], _) when num_fields = 0 -> rem
-| Tpat_record ((_, lbl, _) :: _ as lbl_pat_list, _)
-  when Array.length lbl.lbl_all = num_fields ->
-    record_matching_line num_fields lbl_pat_list @ rem
-| _ -> raise NoMatch
-
-let make_record_matching loc all_labels def = function
-    [] -> fatal_error "Matching.make_record_matching"
-  | ((arg, _mut) :: argl) ->
-      let rec make_args pos =
-        if pos >= Array.length all_labels then argl else begin
-          let lbl = all_labels.(pos) in
-          let access =
-            match lbl.lbl_repres with
-            | Record_regular | Record_inlined _ ->
-              Lprim (Pfield lbl.lbl_pos, [arg], loc)
-            | Record_unboxed _ -> arg
-            | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [arg], loc)
-            | Record_extension _ -> Lprim (Pfield (lbl.lbl_pos + 1), [arg], loc)
-          in
-          let str =
-            match lbl.lbl_mut with
-              Immutable -> Alias
-            | Mutable -> StrictOpt in
-          (access, str) :: make_args(pos + 1)
-        end in
-      let nfields = Array.length all_labels in
-      let def= make_default (matcher_record nfields) def in
-      {cases = []; args = make_args 0 ; default = def}
-
-
-let divide_record all_labels p ctx pm =
-  let get_args = get_args_record (Array.length all_labels) in
-  divide_line
-    (filter_ctx p)
-    (make_record_matching p.pat_loc all_labels)
-    get_args
-    p ctx pm
-
-(* Matching against an array pattern *)
-
-let get_key_array = function
-  | {pat_desc=Tpat_array patl} -> List.length patl
-  | _ -> assert false
-
-let get_args_array p rem = match p with
-| {pat_desc=Tpat_array patl} -> patl@rem
-| _ -> assert false
-
-let matcher_array len p rem = match p.pat_desc with
-| Tpat_or (_,_,_) -> raise OrPat
-| Tpat_array args when List.length args=len -> args @ rem
-| Tpat_any -> Parmatch.omegas len @ rem
-| _ -> raise NoMatch
-
-let make_array_matching kind p def ctx = function
-  | [] -> fatal_error "Matching.make_array_matching"
-  | ((arg, _mut) :: argl) ->
-      let len = get_key_array p in
-      let rec make_args pos =
-        if pos >= len
-        then argl
-        else (Lprim(Parrayrefu kind,
-                    [arg; Lconst(Const_base(Const_int pos))],
-                    p.pat_loc),
-              StrictOpt) :: make_args (pos + 1) in
-      let def = make_default (matcher_array len) def
-      and ctx = filter_ctx p ctx in
-      {pm={cases = []; args = make_args 0 ; default = def} ;
-        ctx=ctx ;
-        pat = normalize_pat p}
-
-let divide_array kind ctx pm =
-  divide
-    (make_array_matching kind)
-    (=) get_key_array get_args_array ctx pm
-
-
-(*
-   Specific string test sequence
-   Will be called by the bytecode compiler, from bytegen.ml.
-   The strategy is first dichotomic search (we perform 3-way tests
-   with compare_string), then sequence of equality tests
-   when there are less then T=strings_test_threshold static strings to match.
-
-  Increasing T entails (slightly) less code, decreasing T
-  (slightly) favors runtime speed.
-  T=8 looks a decent tradeoff.
-*)
-
-(* Utilities *)
-
-let strings_test_threshold = 8
-
-let prim_string_notequal =
-  Pccall(Primitive.simple
-           ~name:"caml_string_notequal"
-           ~arity:2
-           ~alloc:false)
-
-let prim_string_compare =
-  Pccall(Primitive.simple
-           ~name:"caml_string_compare"
-           ~arity:2
-           ~alloc:false)
-
-let bind_sw arg k = match arg with
-| Lvar _ -> k arg
-| _ ->
-    let id = Ident.create_local "switch" in
-    Llet (Strict,Pgenval,id,arg,k (Lvar id))
-
-
-(* Sequential equality tests *)
-
-let make_string_test_sequence loc arg sw d =
-  let d,sw = match d with
-  | None ->
-      begin match sw with
-      | (_,d)::sw -> d,sw
-      | [] -> assert false
-      end
-  | Some d -> d,sw in
-  bind_sw arg
-    (fun arg ->
-      List.fold_right
-        (fun (s,lam) k ->
-          Lifthenelse
-            (Lprim
-               (prim_string_notequal,
-                [arg; Lconst (Const_immstring s)], loc),
-             k,lam))
-        sw d)
-
-let rec split k xs = match xs with
-| [] -> assert false
-| x0::xs ->
-    if k <= 1 then [],x0,xs
-    else
-      let xs,y0,ys = split (k-2) xs in
-      x0::xs,y0,ys
-
-let zero_lam  = Lconst (Const_base (Const_int 0))
-
-let tree_way_test loc arg lt eq gt =
-  Lifthenelse
-    (Lprim (Pintcomp Clt,[arg;zero_lam], loc),lt,
-     Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg], loc),gt,eq))
-
-(* Dichotomic tree *)
-
-
-let rec do_make_string_test_tree loc arg sw delta d =
-  let len = List.length sw in
-  if len <= strings_test_threshold+delta then
-    make_string_test_sequence loc arg sw d
-  else
-    let lt,(s,act),gt = split len sw in
-    bind_sw
-      (Lprim
-         (prim_string_compare,
-          [arg; Lconst (Const_immstring s)], loc))
-      (fun r ->
-        tree_way_test loc r
-          (do_make_string_test_tree loc arg lt delta d)
-          act
-          (do_make_string_test_tree loc arg gt delta d))
-
-(* Entry point *)
-let expand_stringswitch loc arg sw d = match d with
-| None ->
-    bind_sw arg
-      (fun arg -> do_make_string_test_tree loc arg sw 0 None)
-| Some e ->
-    bind_sw arg
-      (fun arg ->
-        make_catch e
-          (fun d -> do_make_string_test_tree loc arg sw 1 (Some d)))
-
-(**********************)
-(* Generic test trees *)
-(**********************)
-
-(* Sharing *)
-
-(* Add handler, if shared *)
-let handle_shared () =
-  let hs = ref (fun x -> x) in
-  let handle_shared act = match act with
-  | Switch.Single act -> act
-  | Switch.Shared act ->
-      let i,h = make_catch_delayed act in
-      let ohs = !hs in
-      hs := (fun act -> h (ohs act)) ;
-      make_exit i in
-  hs,handle_shared
-
-
-let share_actions_tree sw d =
-  let store = StoreExp.mk_store () in
-(* Default action is always shared *)
-  let d =
-    match d with
-    | None -> None
-    | Some d -> Some (store.Switch.act_store_shared () d) in
-(* Store all other actions *)
-  let sw =
-    List.map  (fun (cst,act) -> cst,store.Switch.act_store () act) sw in
-
-(* Retrieve all actions, including potential default *)
-  let acts = store.Switch.act_get_shared () in
-
-(* Array of actual actions *)
-  let hs,handle_shared = handle_shared () in
-  let acts = Array.map handle_shared acts in
-
-(* Reconstruct default and switch list *)
-  let d = match d with
-  | None -> None
-  | Some d -> Some (acts.(d)) in
-  let sw = List.map (fun (cst,j) -> cst,acts.(j)) sw in
-  !hs,sw,d
-
-(* Note: dichotomic search requires sorted input with no duplicates *)
-let rec uniq_lambda_list sw = match sw with
-  | []|[_] -> sw
-  | (c1,_ as p1)::((c2,_)::sw2 as sw1) ->
-      if const_compare c1 c2 = 0 then uniq_lambda_list (p1::sw2)
-      else p1::uniq_lambda_list sw1
-
-let sort_lambda_list l =
-  let l =
-    List.stable_sort (fun (x,_) (y,_) -> const_compare x y) l in
-  uniq_lambda_list l
-
-let rec cut n l =
-  if n = 0 then [],l
-  else match l with
-    [] -> raise (Invalid_argument "cut")
-  | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2
-
-let rec do_tests_fail loc fail tst arg = function
-  | [] -> fail
-  | (c, act)::rem ->
-      Lifthenelse
-        (Lprim (tst, [arg ; Lconst (Const_base c)], loc),
-         do_tests_fail loc fail tst arg rem,
-         act)
-
-let rec do_tests_nofail loc tst arg = function
-  | [] -> fatal_error "Matching.do_tests_nofail"
-  | [_,act] -> act
-  | (c,act)::rem ->
-      Lifthenelse
-        (Lprim (tst, [arg ; Lconst (Const_base c)], loc),
-         do_tests_nofail loc tst arg rem,
-         act)
-
-let make_test_sequence loc fail tst lt_tst arg const_lambda_list =
-  let const_lambda_list = sort_lambda_list const_lambda_list in
-  let hs,const_lambda_list,fail =
-    share_actions_tree const_lambda_list fail in
-
-  let rec make_test_sequence const_lambda_list =
-    if List.length const_lambda_list >= 4 && lt_tst <> Pignore then
-      split_sequence const_lambda_list
-    else match fail with
-    | None -> do_tests_nofail loc tst arg const_lambda_list
-    | Some fail -> do_tests_fail loc fail tst arg const_lambda_list
-
-  and split_sequence const_lambda_list =
-    let list1, list2 =
-      cut (List.length const_lambda_list / 2) const_lambda_list in
-    Lifthenelse(Lprim(lt_tst,
-                      [arg; Lconst(Const_base (fst(List.hd list2)))],
-                      loc),
-                make_test_sequence list1, make_test_sequence list2)
-  in
-  hs (make_test_sequence const_lambda_list)
-
-
-module SArg = struct
-  type primitive = Lambda.primitive
-
-  let eqint = Pintcomp Ceq
-  let neint = Pintcomp Cne
-  let leint = Pintcomp Cle
-  let ltint = Pintcomp Clt
-  let geint = Pintcomp Cge
-  let gtint = Pintcomp Cgt
-
-  type act = Lambda.lambda
-
-  let make_prim p args = Lprim (p,args,Location.none)
-  let make_offset arg n = match n with
-  | 0 -> arg
-  | _ -> Lprim (Poffsetint n,[arg],Location.none)
-
-  let bind arg body =
-    let newvar,newarg = match arg with
-    | Lvar v -> v,arg
-    | _      ->
-        let newvar = Ident.create_local "switcher" in
-        newvar,Lvar newvar in
-    bind Alias newvar arg (body newarg)
-  let make_const i = Lconst (Const_base (Const_int i))
-  let make_isout h arg = Lprim (Pisout, [h ; arg],Location.none)
-  let make_isin h arg = Lprim (Pnot,[make_isout h arg],Location.none)
-  let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot)
-  let make_switch loc arg cases acts =
-    let l = ref [] in
-    for i = Array.length cases-1 downto 0 do
-      l := (i,acts.(cases.(i))) ::  !l
-    done ;
-    Lswitch(arg,
-            {sw_numconsts = Array.length cases ; sw_consts = !l ;
-             sw_numblocks = 0 ; sw_blocks =  []  ;
-             sw_failaction = None}, loc)
-  let make_catch  = make_catch_delayed
-  let make_exit = make_exit
-
-end
-
-(* Action sharing for Lswitch argument *)
-let share_actions_sw sw =
-(* Attempt sharing on all actions *)
-  let store = StoreExp.mk_store () in
-  let fail = match sw.sw_failaction with
-  | None -> None
-  | Some fail ->
-      (* Fail is translated to exit, whatever happens *)
-      Some (store.Switch.act_store_shared () fail) in
-  let consts =
-    List.map
-      (fun (i,e) -> i,store.Switch.act_store () e)
-      sw.sw_consts
-  and blocks =
-    List.map
-      (fun (i,e) -> i,store.Switch.act_store () e)
-      sw.sw_blocks in
-  let acts = store.Switch.act_get_shared () in
-  let hs,handle_shared = handle_shared () in
-  let acts = Array.map handle_shared acts in
-  let fail = match fail with
-  | None -> None
-  | Some fail -> Some (acts.(fail)) in
-  !hs,
-  { sw with
-    sw_consts = List.map (fun (i,j) -> i,acts.(j)) consts ;
-    sw_blocks = List.map (fun (i,j) -> i,acts.(j)) blocks ;
-    sw_failaction = fail; }
-
-(* Reintroduce fail action in switch argument,
-   for the sake of avoiding carrying over huge switches *)
-
-let reintroduce_fail sw = match sw.sw_failaction with
-| None ->
-    let t = Hashtbl.create 17 in
-    let seen (_,l) = match as_simple_exit l with
-    | Some i ->
-        let old = try Hashtbl.find t i with Not_found -> 0 in
-        Hashtbl.replace t i (old+1)
-    | None -> () in
-    List.iter seen sw.sw_consts ;
-    List.iter seen sw.sw_blocks ;
-    let i_max = ref (-1)
-    and max = ref (-1) in
-    Hashtbl.iter
-      (fun i c ->
-        if c > !max then begin
-          i_max := i ;
-          max := c
-        end) t ;
-    if !max >= 3 then
-      let default = !i_max in
-      let remove =
-        List.filter
-          (fun (_,lam) -> match as_simple_exit lam with
-          | Some j -> j <> default
-          | None -> true) in
-      {sw with
-       sw_consts = remove sw.sw_consts ;
-       sw_blocks = remove sw.sw_blocks ;
-       sw_failaction = Some (make_exit default)}
-    else sw
-| Some _ -> sw
-
-
-module Switcher = Switch.Make(SArg)
-open Switch
-
-let rec last def = function
-  | [] -> def
-  | [x,_] -> x
-  | _::rem -> last def rem
-
-let get_edges low high l = match l with
-| [] -> low, high
-| (x,_)::_ -> x, last high l
-
-
-let as_interval_canfail fail low high l =
-  let store = StoreExp.mk_store () in
-
-  let do_store _tag act =
-
-    let i =  store.act_store () act in
-(*
-    eprintf "STORE [%s] %i %s\n" tag i (string_of_lam act) ;
-*)
-    i in
-
-  let rec nofail_rec cur_low cur_high cur_act = function
-    | [] ->
-        if cur_high = high then
-          [cur_low,cur_high,cur_act]
-        else
-          [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)]
-    | ((i,act_i)::rem) as all ->
-        let act_index = do_store "NO" act_i in
-        if cur_high+1= i then
-          if act_index=cur_act then
-            nofail_rec cur_low i cur_act rem
-          else if act_index=0 then
-            (cur_low,i-1, cur_act)::fail_rec i i rem
-          else
-            (cur_low, i-1, cur_act)::nofail_rec i i act_index rem
-        else if act_index = 0 then
-          (cur_low, cur_high, cur_act)::
-          fail_rec (cur_high+1) (cur_high+1) all
-        else
-          (cur_low, cur_high, cur_act)::
-          (cur_high+1,i-1,0)::
-          nofail_rec i i act_index rem
-
-  and fail_rec cur_low cur_high = function
-    | [] -> [(cur_low, cur_high, 0)]
-    | (i,act_i)::rem ->
-        let index = do_store "YES" act_i in
-        if index=0 then fail_rec cur_low i rem
-        else
-          (cur_low,i-1,0)::
-          nofail_rec i i index rem in
-
-  let init_rec = function
-    | [] -> [low,high,0]
-    | (i,act_i)::rem ->
-        let index = do_store "INIT" act_i in
-        if index=0 then
-          fail_rec low i rem
-        else
-          if low < i then
-            (low,i-1,0)::nofail_rec i i index rem
-          else
-            nofail_rec i i index rem in
-
-  assert (do_store "FAIL" fail = 0) ; (* fail has action index 0 *)
-  let r = init_rec l in
-  Array.of_list r,  store
-
-let as_interval_nofail l =
-  let store = StoreExp.mk_store () in
-  let rec some_hole = function
-    | []|[_] -> false
-    | (i,_)::((j,_)::_ as rem) ->
-        j > i+1 || some_hole rem in
-  let rec i_rec cur_low cur_high cur_act = function
-    | [] ->
-        [cur_low, cur_high, cur_act]
-    | (i,act)::rem ->
-        let act_index = store.act_store () act in
-        if act_index = cur_act then
-          i_rec cur_low i cur_act rem
-        else
-          (cur_low, cur_high, cur_act)::
-          i_rec i i act_index rem in
-  let inters = match l with
-  | (i,act)::rem ->
-      let act_index =
-        (* In case there is some hole and that a switch is emitted,
-           action 0 will be used as the action of unreachable
-           cases (cf. switch.ml, make_switch).
-           Hence, this action will be shared *)
-        if some_hole rem then
-          store.act_store_shared () act
-        else
-          store.act_store () act in
-      assert (act_index = 0) ;
-      i_rec i i act_index rem
-  | _ -> assert false in
-
-  Array.of_list inters, store
-
-
-let sort_int_lambda_list l =
-  List.sort
-    (fun (i1,_) (i2,_) ->
-      if i1 < i2 then -1
-      else if i2 < i1 then 1
-      else 0)
-    l
-
-let as_interval fail low high l =
-  let l = sort_int_lambda_list l in
-  get_edges low high l,
-  (match fail with
-  | None -> as_interval_nofail l
-  | Some act -> as_interval_canfail act low high l)
-
-let call_switcher loc fail arg low high int_lambda_list =
-  let edges, (cases, actions) =
-    as_interval fail low high int_lambda_list in
-  Switcher.zyva loc edges arg cases actions
-
-
-let rec list_as_pat = function
-  | [] -> fatal_error "Matching.list_as_pat"
-  | [pat] -> pat
-  | pat::rem ->
-      {pat with pat_desc = Tpat_or (pat,list_as_pat rem,None)}
-
-
-let complete_pats_constrs = function
-  | p::_ as pats ->
-      List.map
-        (pat_of_constr p)
-        (complete_constrs p (List.map get_key_constr pats))
-  | _ -> assert false
-
-
-(*
-     Following two ``failaction'' function compute n, the trap handler
-    to jump to in case of failure of elementary tests
-*)
-
-let mk_failaction_neg partial ctx def = match partial with
-| Partial ->
-    begin match def with
-    | (_,idef)::_ ->
-        Some (Lstaticraise (idef,[])),jumps_singleton idef ctx
-    | [] ->
-       (* Act as Total, this means
-          If no appropriate default matrix exists,
-          then this switch cannot fail *)
-        None, jumps_empty
-    end
-| Total ->
-    None, jumps_empty
-
-
-
-(* In line with the article and simpler than before *)
-let mk_failaction_pos partial seen ctx defs  =
-  if dbg then begin
-    Format.eprintf "**POS**\n" ;
-    pretty_def defs ;
-    ()
-  end ;
-  let rec scan_def env to_test defs = match to_test,defs with
-  | ([],_)|(_,[]) ->
-      List.fold_left
-        (fun  (klist,jumps) (pats,i)->
-          let action = Lstaticraise (i,[]) in
-          let klist =
-            List.fold_right
-              (fun pat r -> (get_key_constr pat,action)::r)
-              pats klist
-          and jumps =
-            jumps_add i (ctx_lub (list_as_pat pats) ctx) jumps in
-          klist,jumps)
-        ([],jumps_empty) env
-  | _,(pss,idef)::rem ->
-      let now, later =
-        List.partition
-          (fun (_p,p_ctx) -> ctx_match p_ctx pss) to_test in
-      match now with
-      | [] -> scan_def env to_test rem
-      | _  -> scan_def ((List.map fst now,idef)::env) later rem in
-
-  let fail_pats = complete_pats_constrs seen in
-  if List.length fail_pats < !Clflags.match_context_rows then begin
-    let fail,jmps =
-      scan_def
-        []
-        (List.map
-           (fun pat -> pat, ctx_lub pat ctx)
-           fail_pats)
-        defs in
-    if dbg then begin
-      eprintf "POSITIVE JUMPS [%i]:\n" (List.length fail_pats);
-      pretty_jumps jmps
-    end ;
-    None,fail,jmps
-  end else begin (* Too many non-matched constructors -> reduced information *)
-    if dbg then eprintf "POS->NEG!!!\n%!" ;
-    let fail,jumps =  mk_failaction_neg partial ctx defs in
-    if dbg then
-      eprintf "FAIL: %s\n"
-        (match fail with
-        | None -> "<none>"
-        | Some lam -> string_of_lam lam) ;
-    fail,[],jumps
-  end
-
-let combine_constant loc arg cst partial ctx def
-    (const_lambda_list, total, _pats) =
-  let fail, local_jumps =
-    mk_failaction_neg partial ctx def in
-  let lambda1 =
-    match cst with
-    | Const_int _ ->
-        let int_lambda_list =
-          List.map (function Const_int n, l -> n,l | _ -> assert false)
-            const_lambda_list in
-        call_switcher loc fail arg min_int max_int int_lambda_list
-    | Const_char _ ->
-        let int_lambda_list =
-          List.map (function Const_char c, l -> (Char.code c, l)
-            | _ -> assert false)
-            const_lambda_list in
-        call_switcher loc fail arg 0 255 int_lambda_list
-    | Const_string _ ->
-(* Note as the bytecode compiler may resort to dichotomic search,
-   the clauses of stringswitch  are sorted with duplicates removed.
-   This partly applies to the native code compiler, which requires
-   no duplicates *)
-        let const_lambda_list = sort_lambda_list const_lambda_list in
-        let sw =
-          List.map
-            (fun (c,act) -> match c with
-            | Const_string (s,_) -> s,act
-            | _ -> assert false)
-            const_lambda_list in
-        let hs,sw,fail = share_actions_tree sw fail in
-        hs (Lstringswitch (arg,sw,fail,loc))
-    | Const_float _ ->
-        make_test_sequence loc
-          fail
-          (Pfloatcomp CFneq) (Pfloatcomp CFlt)
-          arg const_lambda_list
-    | Const_int32 _ ->
-        make_test_sequence loc
-          fail
-          (Pbintcomp(Pint32, Cne)) (Pbintcomp(Pint32, Clt))
-          arg const_lambda_list
-    | Const_int64 _ ->
-        make_test_sequence loc
-          fail
-          (Pbintcomp(Pint64, Cne)) (Pbintcomp(Pint64, Clt))
-          arg const_lambda_list
-    | Const_nativeint _ ->
-        make_test_sequence loc
-          fail
-          (Pbintcomp(Pnativeint, Cne)) (Pbintcomp(Pnativeint, Clt))
-          arg const_lambda_list
-  in lambda1,jumps_union local_jumps total
-
-
-
-let split_cases tag_lambda_list =
-  let rec split_rec = function
-      [] -> ([], [])
-    | (cstr, act) :: rem ->
-        let (consts, nonconsts) = split_rec rem in
-        match cstr with
-          Cstr_constant n -> ((n, act) :: consts, nonconsts)
-        | Cstr_block n    -> (consts, (n, act) :: nonconsts)
-        | Cstr_unboxed    -> (consts, (0, act) :: nonconsts)
-        | Cstr_extension _ -> assert false in
-  let const, nonconst = split_rec tag_lambda_list in
-  sort_int_lambda_list const,
-  sort_int_lambda_list nonconst
-
-let split_extension_cases tag_lambda_list =
-  let rec split_rec = function
-      [] -> ([], [])
-    | (cstr, act) :: rem ->
-        let (consts, nonconsts) = split_rec rem in
-        match cstr with
-          Cstr_extension(path, true) -> ((path, act) :: consts, nonconsts)
-        | Cstr_extension(path, false) -> (consts, (path, act) :: nonconsts)
-        | _ -> assert false in
-  split_rec tag_lambda_list
-
-
-let combine_constructor loc arg ex_pat cstr partial ctx def
-    (tag_lambda_list, total1, pats) =
-  if cstr.cstr_consts < 0 then begin
-    (* Special cases for extensions *)
-    let fail, local_jumps =
-      mk_failaction_neg partial ctx def in
-    let lambda1 =
-      let consts, nonconsts = split_extension_cases tag_lambda_list in
-      let default, consts, nonconsts =
-        match fail with
-        | None ->
-            begin match consts, nonconsts with
-            | _, (_, act)::rem -> act, consts, rem
-            | (_, act)::rem, _ -> act, rem, nonconsts
-            | _ -> assert false
-            end
-        | Some fail -> fail, consts, nonconsts in
-      let nonconst_lambda =
-        match nonconsts with
-          [] -> default
-        | _ ->
-            let tag = Ident.create_local "tag" in
-            let tests =
-              List.fold_right
-                (fun (path, act) rem ->
-                   let ext = transl_extension_path loc ex_pat.pat_env path in
-                   Lifthenelse(Lprim(Pintcomp Ceq, [Lvar tag; ext], loc),
-                               act, rem))
-                nonconsts
-                default
-            in
-              Llet(Alias, Pgenval,tag, Lprim(Pfield 0, [arg], loc), tests)
-      in
-        List.fold_right
-          (fun (path, act) rem ->
-             let ext = transl_extension_path loc ex_pat.pat_env path in
-             Lifthenelse(Lprim(Pintcomp Ceq, [arg; ext], loc),
-                         act, rem))
-          consts
-          nonconst_lambda
-    in
-    lambda1, jumps_union local_jumps total1
-  end else begin
-    (* Regular concrete type *)
-    let ncases = List.length tag_lambda_list
-    and nconstrs =  cstr.cstr_consts + cstr.cstr_nonconsts in
-    let sig_complete = ncases = nconstrs in
-    let fail_opt,fails,local_jumps =
-      if sig_complete then None,[],jumps_empty
-      else
-        mk_failaction_pos partial pats ctx def in
-
-    let tag_lambda_list = fails @ tag_lambda_list in
-    let (consts, nonconsts) = split_cases tag_lambda_list in
-    let lambda1 =
-      match fail_opt,same_actions tag_lambda_list with
-      | None,Some act -> act (* Identical actions, no failure *)
-      | _ ->
-          match
-            (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts)
-          with
-          | (1, 1, [0, act1], [0, act2]) ->
-           (* Typically, match on lists, will avoid isint primitive in that
-              case *)
-              Lifthenelse(arg, act2, act1)
-          | (n,0,_,[])  -> (* The type defines constant constructors only *)
-              call_switcher loc fail_opt arg 0 (n-1) consts
-          | (n, _, _, _) ->
-              let act0  =
-                (* = Some act when all non-const constructors match to act *)
-                match fail_opt,nonconsts with
-                | Some a,[] -> Some a
-                | Some _,_ ->
-                    if List.length nonconsts = cstr.cstr_nonconsts then
-                      same_actions nonconsts
-                    else None
-                | None,_ -> same_actions nonconsts in
-              match act0 with
-              | Some act ->
-                  Lifthenelse
-                    (Lprim (Pisint, [arg], loc),
-                     call_switcher loc
-                       fail_opt arg
-                       0 (n-1) consts,
-                     act)
-(* Emit a switch, as bytecode implements this sophisticated instruction *)
-              | None ->
-                  let sw =
-                    {sw_numconsts = cstr.cstr_consts; sw_consts = consts;
-                     sw_numblocks = cstr.cstr_nonconsts; sw_blocks = nonconsts;
-                     sw_failaction = fail_opt} in
-                  let hs,sw = share_actions_sw sw in
-                  let sw = reintroduce_fail sw in
-                  hs (Lswitch (arg,sw,loc)) in
-    lambda1, jumps_union local_jumps total1
-  end
-
-let make_test_sequence_variant_constant fail arg int_lambda_list =
-  let _, (cases, actions) =
-    as_interval fail min_int max_int int_lambda_list in
-  Switcher.test_sequence arg cases actions
-
-let call_switcher_variant_constant loc fail arg int_lambda_list =
-  call_switcher loc fail arg min_int max_int int_lambda_list
-
-
-let call_switcher_variant_constr loc fail arg int_lambda_list =
-  let v = Ident.create_local "variant" in
-  Llet(Alias, Pgenval, v, Lprim(Pfield 0, [arg], loc),
-       call_switcher loc
-         fail (Lvar v) min_int max_int int_lambda_list)
-
-let combine_variant loc row arg partial ctx def
-                    (tag_lambda_list, total1, _pats) =
-  let row = Btype.row_repr row in
-  let num_constr = ref 0 in
-  if row.row_closed then
-    List.iter
-      (fun (_, f) ->
-        match Btype.row_field_repr f with
-          Rabsent | Reither(true, _::_, _, _) -> ()
-        | _ -> incr num_constr)
-      row.row_fields
-  else
-    num_constr := max_int;
-  let test_int_or_block arg if_int if_block =
-    Lifthenelse(Lprim (Pisint, [arg], loc), if_int, if_block) in
-  let sig_complete =  List.length tag_lambda_list = !num_constr
-  and one_action = same_actions tag_lambda_list in
-  let fail, local_jumps =
-    if
-      sig_complete  || (match partial with Total -> true | _ -> false)
-    then
-      None, jumps_empty
-    else
-      mk_failaction_neg partial ctx def in
-  let (consts, nonconsts) = split_cases tag_lambda_list in
-  let lambda1 = match fail, one_action with
-  | None, Some act -> act
-  | _,_ ->
-      match (consts, nonconsts) with
-      | ([_, act1], [_, act2]) when fail=None ->
-          test_int_or_block arg act1 act2
-      | (_, []) -> (* One can compare integers and pointers *)
-          make_test_sequence_variant_constant fail arg consts
-      | ([], _) ->
-          let lam = call_switcher_variant_constr loc
-              fail arg nonconsts in
-          (* One must not dereference integers *)
-          begin match fail with
-          | None -> lam
-          | Some fail -> test_int_or_block arg fail lam
-          end
-      | (_, _) ->
-          let lam_const =
-            call_switcher_variant_constant loc
-              fail arg consts
-          and lam_nonconst =
-            call_switcher_variant_constr loc
-              fail arg nonconsts in
-          test_int_or_block arg lam_const lam_nonconst
-  in
-  lambda1, jumps_union local_jumps total1
-
-
-let combine_array loc arg kind partial ctx def
-    (len_lambda_list, total1, _pats)  =
-  let fail, local_jumps = mk_failaction_neg partial  ctx def in
-  let lambda1 =
-    let newvar = Ident.create_local "len" in
-    let switch =
-      call_switcher loc
-        fail (Lvar newvar)
-        0 max_int len_lambda_list in
-    bind
-      Alias newvar (Lprim(Parraylength kind, [arg], loc)) switch in
-  lambda1, jumps_union local_jumps total1
-
-(* Insertion of debugging events *)
-
-let rec event_branch repr lam =
-  begin match lam, repr with
-    (_, None) ->
-      lam
-  | (Levent(lam', ev), Some r) ->
-      incr r;
-      Levent(lam', {lev_loc = ev.lev_loc;
-                    lev_kind = ev.lev_kind;
-                    lev_repr = repr;
-                    lev_env = ev.lev_env})
-  | (Llet(str, k, id, lam, body), _) ->
-      Llet(str, k, id, lam, event_branch repr body)
-  | Lstaticraise _,_ -> lam
-  | (_, Some _) ->
-      Printlambda.lambda Format.str_formatter lam ;
-      fatal_error
-        ("Matching.event_branch: "^Format.flush_str_formatter ())
-  end
-
-
-(*
-   This exception is raised when the compiler cannot produce code
-   because control cannot reach the compiled clause,
-
-   Unused is raised initially in compile_test.
-
-   compile_list (for compiling switch results) catch Unused
-
-   comp_match_handlers (for compiling split matches)
-   may reraise Unused
-
-
-*)
-
-exception Unused
-
-let compile_list compile_fun division =
-
-  let rec c_rec totals = function
-  | [] -> [], jumps_unions totals, []
-  | (key, cell) :: rem ->
-      begin match cell.ctx with
-      | [] -> c_rec totals rem
-      | _  ->
-          try
-            let (lambda1, total1) = compile_fun cell.ctx cell.pm in
-            let c_rem, total, new_pats =
-              c_rec
-                (jumps_map ctx_combine total1::totals) rem in
-            ((key,lambda1)::c_rem), total, (cell.pat::new_pats)
-          with
-          | Unused -> c_rec totals rem
-      end in
-  c_rec [] division
-
-
-let compile_orhandlers compile_fun lambda1 total1 ctx to_catch =
-  let rec do_rec r total_r = function
-    | [] -> r,total_r
-    | (mat,i,vars,pm)::rem ->
-        begin try
-          let ctx = select_columns mat ctx in
-          let handler_i, total_i =
-            compile_fun ctx pm in
-          match raw_action r with
-          | Lstaticraise (j,args) ->
-              if i=j then
-                List.fold_right2 (bind_with_value_kind Alias)
-                  vars args handler_i,
-                jumps_map (ctx_rshift_num (ncols mat)) total_i
-              else
-                do_rec r total_r rem
-          | _ ->
-              do_rec
-                (Lstaticcatch (r,(i,vars), handler_i))
-                (jumps_union
-                   (jumps_remove i total_r)
-                   (jumps_map (ctx_rshift_num (ncols mat)) total_i))
-              rem
-        with
-        | Unused ->
-            do_rec (Lstaticcatch (r, (i,vars), lambda_unit)) total_r rem
-        end in
-  do_rec lambda1 total1 to_catch
-
-
-let compile_test compile_fun partial divide combine ctx to_match =
-  let division = divide ctx to_match in
-  let c_div = compile_list compile_fun division in
-  match c_div with
-  | [],_,_ ->
-     begin match mk_failaction_neg partial ctx to_match.default with
-     | None,_ -> raise Unused
-     | Some l,total -> l,total
-     end
-  | _ ->
-      combine ctx to_match.default c_div
-
-(* Attempt to avoid some useless bindings by lowering them *)
-
-(* Approximation of v present in lam *)
-let rec approx_present v = function
-  | Lconst _ -> false
-  | Lstaticraise (_,args) ->
-      List.exists (fun lam -> approx_present v lam) args
-  | Lprim (_,args,_) ->
-      List.exists (fun lam -> approx_present v lam) args
-  | Llet (Alias, _k, _, l1, l2) ->
-      approx_present v l1 || approx_present v l2
-  | Lvar vv -> Ident.same v vv
-  | _ -> true
-
-let rec lower_bind v arg lam = match lam with
-| Lifthenelse (cond, ifso, ifnot) ->
-    let pcond = approx_present v cond
-    and pso = approx_present v ifso
-    and pnot = approx_present v ifnot in
-    begin match pcond, pso, pnot with
-    | false, false, false -> lam
-    | false, true, false ->
-        Lifthenelse (cond, lower_bind v arg ifso, ifnot)
-    | false, false, true ->
-        Lifthenelse (cond, ifso, lower_bind v arg ifnot)
-    | _,_,_ -> bind Alias v arg lam
-    end
-| Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw), loc)
-    when not (approx_present v ls) ->
-      Lswitch (ls, {sw with sw_consts = [i,lower_bind v arg act]}, loc)
-| Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw), loc)
-    when not (approx_present v ls) ->
-      Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]}, loc)
-| Llet (Alias, k, vv, lv, l) ->
-    if approx_present v lv then
-      bind Alias v arg lam
-    else
-      Llet (Alias, k, vv, lv, lower_bind v arg l)
-| _ ->
-    bind Alias v arg lam
-
-let bind_check str v arg lam = match str,arg with
-| _, Lvar _ ->bind str v arg lam
-| Alias,_ -> lower_bind v arg lam
-| _,_     -> bind str v arg lam
-
-let comp_exit ctx m = match m.default with
-| (_,i)::_ -> Lstaticraise (i,[]), jumps_singleton i ctx
-| _        -> fatal_error "Matching.comp_exit"
-
-
-
-let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs =
-  match next_matchs with
-  | [] -> comp_fun partial ctx arg first_match
-  | rem ->
-      let rec c_rec body total_body = function
-        | [] -> body, total_body
-        (* Hum, -1 means never taken
-        | (-1,pm)::rem -> c_rec body total_body rem *)
-        | (i,pm)::rem ->
-            let ctx_i,total_rem = jumps_extract i total_body in
-            begin match ctx_i with
-            | [] -> c_rec body total_body rem
-            | _ ->
-                try
-                  let li,total_i =
-                    comp_fun
-                      (match rem with [] -> partial | _ -> Partial)
-                      ctx_i arg pm in
-                  c_rec
-                    (Lstaticcatch (body,(i,[]),li))
-                    (jumps_union total_i total_rem)
-                    rem
-                with
-                | Unused ->
-                    c_rec (Lstaticcatch (body,(i,[]),lambda_unit))
-                      total_rem  rem
-            end in
-   try
-      let first_lam,total = comp_fun Partial ctx arg first_match in
-      c_rec first_lam total rem
-   with Unused -> match next_matchs with
-   | [] -> raise Unused
-   | (_,x)::xs ->  comp_match_handlers comp_fun partial ctx arg x xs
-
-(* To find reasonable names for variables *)
-
-let rec name_pattern default = function
-    (pat :: _, _) :: rem ->
-      begin match pat.pat_desc with
-        Tpat_var (id, _) -> id
-      | Tpat_alias(_, id, _) -> id
-      | _ -> name_pattern default rem
-      end
-  | _ -> Ident.create_local default
-
-let arg_to_var arg cls = match arg with
-| Lvar v -> v,arg
-| _ ->
-    let v = name_pattern "*match*" cls in
-    v,Lvar v
-
-
-(*
-  The main compilation function.
-   Input:
-      repr=used for inserting debug events
-      partial=exhaustiveness information from Parmatch
-      ctx=a context
-      m=a pattern matching
-
-   Output: a lambda term, a jump summary {..., exit number -> context, .. }
-*)
-
-let rec compile_match repr partial ctx m = match m with
-| { cases = []; args = [] } -> comp_exit ctx m
-| { cases = ([], action) :: rem } ->
-    if is_guarded action then begin
-      let (lambda, total) =
-        compile_match None partial ctx { m with cases = rem } in
-      event_branch repr (patch_guarded lambda action), total
-    end else
-      (event_branch repr action, jumps_empty)
-| { args = (arg, str)::argl } ->
-    let v,newarg = arg_to_var arg m.cases in
-    let first_match,rem =
-      split_precompile (Some v)
-        { m with args = (newarg, Alias) :: argl } in
-    let (lam, total) =
-      comp_match_handlers
-        ((if dbg then do_compile_matching_pr else do_compile_matching) repr)
-        partial ctx newarg first_match rem in
-    bind_check str v arg lam, total
-| _ -> assert false
-
-
-(* verbose version of do_compile_matching, for debug *)
-
-and do_compile_matching_pr repr partial ctx arg x =
-  Format.eprintf "COMPILE: %s\nMATCH\n"
-    (match partial with Partial -> "Partial" | Total -> "Total") ;
-  pretty_precompiled x ;
-  Format.eprintf "CTX\n" ;
-  pretty_ctx ctx ;
-  let (_, jumps) as r =  do_compile_matching repr partial ctx arg x in
-  Format.eprintf "JUMPS\n" ;
-  pretty_jumps jumps ;
-  r
-
-and do_compile_matching repr partial ctx arg pmh = match pmh with
-| Pm pm ->
-  let pat = what_is_cases pm.cases in
-  begin match pat.pat_desc with
-  | Tpat_any ->
-      compile_no_test
-        divide_var ctx_rshift repr partial ctx pm
-  | Tpat_tuple patl ->
-      compile_no_test
-        (divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine
-        repr partial ctx pm
-  | Tpat_record ((_, lbl,_)::_,_) ->
-      compile_no_test
-        (divide_record lbl.lbl_all (normalize_pat pat))
-        ctx_combine repr partial ctx pm
-  | Tpat_constant cst ->
-      compile_test
-        (compile_match repr partial) partial
-        divide_constant
-        (combine_constant pat.pat_loc arg cst partial)
-        ctx pm
-  | Tpat_construct (_, cstr, _) ->
-      compile_test
-        (compile_match repr partial) partial
-        divide_constructor
-        (combine_constructor pat.pat_loc arg pat cstr partial)
-        ctx pm
-  | Tpat_array _ ->
-      let kind = Typeopt.array_pattern_kind pat in
-      compile_test (compile_match repr partial) partial
-        (divide_array kind) (combine_array pat.pat_loc arg kind partial)
-        ctx pm
-  | Tpat_lazy _ ->
-      compile_no_test
-        (divide_lazy (normalize_pat pat))
-        ctx_combine repr partial ctx pm
-  | Tpat_variant(_, _, row) ->
-      compile_test (compile_match repr partial) partial
-        (divide_variant !row)
-        (combine_variant pat.pat_loc !row arg partial)
-        ctx pm
-  | _ -> assert false
-  end
-| PmVar {inside=pmh ; var_arg=arg} ->
-    let lam, total =
-      do_compile_matching repr partial (ctx_lshift ctx) arg pmh in
-    lam, jumps_map ctx_rshift total
-| PmOr {body=body ; handlers=handlers} ->
-    let lam, total = compile_match repr partial ctx body in
-    compile_orhandlers (compile_match repr partial) lam total ctx handlers
-
-and compile_no_test divide up_ctx repr partial ctx to_match =
-  let {pm=this_match ; ctx=this_ctx } = divide ctx to_match in
-  let lambda,total = compile_match repr partial this_ctx this_match in
-  lambda, jumps_map up_ctx total
-
-
-
-
-(* The entry points *)
-
-(*
-   If there is a guard in a matching or a lazy pattern,
-   then set exhaustiveness info to Partial.
-   (because of side effects, assume the worst).
-
-   Notice that exhaustiveness information is trusted by the compiler,
-   that is, a match flagged as Total should not fail at runtime.
-   More specifically, for instance if match y with x::_ -> x is flagged
-   total (as it happens during JoCaml compilation) then y cannot be []
-   at runtime. As a consequence, the static Total exhaustiveness information
-   have to be downgraded to Partial, in the dubious cases where guards
-   or lazy pattern execute arbitrary code that may perform side effects
-   and change the subject values.
-LM:
-   Lazy pattern was PR#5992, initial patch by lpw25.
-   I have  generalized the patch, so as to also find mutable fields.
-*)
-
-let find_in_pat pred =
-  let rec find_rec p =
-    pred p.pat_desc ||
-    begin match p.pat_desc with
-    | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p ->
-        find_rec p
-    | Tpat_tuple ps|Tpat_construct (_,_,ps) | Tpat_array ps ->
-        List.exists find_rec ps
-    | Tpat_record (lpats,_) ->
-        List.exists
-          (fun (_, _, p) -> find_rec p)
-          lpats
-    | Tpat_or (p,q,_) ->
-        find_rec p || find_rec q
-    | Tpat_constant _ | Tpat_var _
-    | Tpat_any | Tpat_variant (_,None,_) -> false
-    | Tpat_exception _ -> assert false
-  end in
-  find_rec
-
-let is_lazy_pat = function
-  | Tpat_lazy _ -> true
-  | Tpat_alias _ | Tpat_variant _ | Tpat_record _
-  | Tpat_tuple _|Tpat_construct _ | Tpat_array _
-  | Tpat_or _ | Tpat_constant _ | Tpat_var _ | Tpat_any
-      -> false
-  | Tpat_exception _ -> assert false
-
-let is_lazy p = find_in_pat is_lazy_pat p
-
-let have_mutable_field p = match p with
-| Tpat_record (lps,_) ->
-    List.exists
-      (fun (_,lbl,_) ->
-        match lbl.Types.lbl_mut with
-        | Mutable -> true
-        | Immutable -> false)
-      lps
-| Tpat_alias _ | Tpat_variant _ | Tpat_lazy _
-| Tpat_tuple _|Tpat_construct _ | Tpat_array _
-| Tpat_or _
-| Tpat_constant _ | Tpat_var _ | Tpat_any
-  -> false
-| Tpat_exception _ -> assert false
-
-let is_mutable p = find_in_pat have_mutable_field p
-
-(* Downgrade Total when
-   1. Matching accesses some mutable fields;
-   2. And there are  guards or lazy patterns.
-*)
-
-let check_partial is_mutable is_lazy pat_act_list = function
-  | Partial -> Partial
-  | Total ->
-      if
-        pat_act_list = [] ||  (* allow empty case list *)
-        List.exists
-          (fun (pats, lam) ->
-            is_mutable pats && (is_guarded lam || is_lazy pats))
-          pat_act_list
-      then Partial
-      else Total
-
-let check_partial_list =
-  check_partial (List.exists is_mutable) (List.exists is_lazy)
-let check_partial = check_partial is_mutable is_lazy
-
-(* have toplevel handler when appropriate *)
-
-let start_ctx n = [{left=[] ; right = omegas n}]
-
-let check_total total lambda i handler_fun =
-  if jumps_is_empty total then
-    lambda
-  else begin
-    Lstaticcatch(lambda, (i,[]), handler_fun())
-  end
-
-let compile_matching repr handler_fun arg pat_act_list partial =
-  let partial = check_partial pat_act_list partial in
-  match partial with
-  | Partial ->
-      let raise_num = next_raise_count () in
-      let pm =
-        { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
-          args = [arg, Strict] ;
-          default = [[[omega]],raise_num]} in
-      begin try
-        let (lambda, total) = compile_match repr partial (start_ctx 1) pm in
-        check_total total lambda raise_num handler_fun
-      with
-      | Unused -> assert false (* ; handler_fun() *)
-      end
-  | Total ->
-      let pm =
-        { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
-          args = [arg, Strict] ;
-          default = []} in
-      let (lambda, total) = compile_match repr partial (start_ctx 1) pm in
-      assert (jumps_is_empty total) ;
-      lambda
-
-
-let partial_function loc () =
-  let slot =
-    transl_extension_path loc
-      Env.initial_safe_string Predef.path_match_failure
-  in
-  let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
-  Lprim(Praise Raise_regular, [Lprim(Pmakeblock(0, Immutable, None),
-          [slot; Lconst(Const_block(0,
-                   [Const_base(Const_string (fname, None));
-                    Const_base(Const_int line);
-                    Const_base(Const_int char)]))], loc)], loc)
-
-let for_function loc repr param pat_act_list partial =
-  compile_matching repr (partial_function loc) param pat_act_list partial
-
-(* In the following two cases, exhaustiveness info is not available! *)
-let for_trywith param pat_act_list =
-  compile_matching None
-    (fun () -> Lprim(Praise Raise_reraise, [param], Location.none))
-    param pat_act_list Partial
-
-let simple_for_let loc param pat body =
-  compile_matching None (partial_function loc) param [pat, body] Partial
-
-
-(* Optimize binding of immediate tuples
-
-   The goal of the implementation of 'for_let' below, which replaces
-   'simple_for_let', is to avoid tuple allocation in cases such as
-   this one:
-
-     let (x,y) =
-        let foo = ... in
-        if foo then (1, 2) else (3,4)
-     in bar
-
-   The compiler easily optimizes the simple `let (x,y) = (1,2) in ...`
-   case (call to Matching.for_multiple_match from Translcore), but
-   didn't optimize situations where the rhs tuples are hidden under
-   a more complex context.
-
-   The idea comes from Alain Frisch who suggested and implemented
-   the following compilation method, based on Lassign:
-
-     let x = dummy in let y = dummy in
-     begin
-      let foo = ... in
-      if foo then
-        (let x1 = 1 in let y1 = 2 in x <- x1; y <- y1)
-      else
-        (let x2 = 3 in let y2 = 4 in x <- x2; y <- y2)
-     end;
-     bar
-
-   The current implementation from Gabriel Scherer uses Lstaticcatch /
-   Lstaticraise instead:
-
-     catch
-       let foo = ... in
-       if foo then
-         (let x1 = 1 in let y1 = 2 in exit x1 y1)
-       else
-        (let x2 = 3 in let y2 = 4 in exit x2 y2)
-     with x y ->
-       bar
-
-   The catch/exit is used to avoid duplication of the let body ('bar'
-   in the example), on 'if' branches for example; it is useless for
-   linear contexts such as 'let', but we don't need to be careful to
-   generate nice code because Simplif will remove such useless
-   catch/exit.
-*)
-
-let rec map_return f = function
-  | Llet (str, k, id, l1, l2) -> Llet (str, k, id, l1, map_return f l2)
-  | Lletrec (l1, l2) -> Lletrec (l1, map_return f l2)
-  | Lifthenelse (lcond, lthen, lelse) ->
-      Lifthenelse (lcond, map_return f lthen, map_return f lelse)
-  | Lsequence (l1, l2) -> Lsequence (l1, map_return f l2)
-  | Levent (l, ev) -> Levent (map_return f l, ev)
-  | Ltrywith (l1, id, l2) -> Ltrywith (map_return f l1, id, map_return f l2)
-  | Lstaticcatch (l1, b, l2) ->
-      Lstaticcatch (map_return f l1, b, map_return f l2)
-  | Lstaticraise _ | Lprim(Praise _, _, _) as l -> l
-  | l -> f l
-
-(* The 'opt' reference indicates if the optimization is worthy.
-
-   It is shared by the different calls to 'assign_pat' performed from
-   'map_return'. For example with the code
-     let (x, y) = if foo then z else (1,2)
-   the else-branch will activate the optimization for both branches.
-
-   That means that the optimization is activated if *there exists* an
-   interesting tuple in one hole of the let-rhs context. We could
-   choose to activate it only if *all* holes are interesting. We made
-   that choice because being optimistic is extremely cheap (one static
-   exit/catch overhead in the "wrong cases"), while being pessimistic
-   can be costly (one unnecessary tuple allocation).
-*)
-
-let assign_pat opt nraise catch_ids loc pat lam =
-  let rec collect acc pat lam = match pat.pat_desc, lam with
-  | Tpat_tuple patl, Lprim(Pmakeblock _, lams, _) ->
-      opt := true;
-      List.fold_left2 collect acc patl lams
-  | Tpat_tuple patl, Lconst(Const_block(_, scl)) ->
-      opt := true;
-      let collect_const acc pat sc = collect acc pat (Lconst sc) in
-      List.fold_left2 collect_const acc patl scl
-  | _ ->
-    (* pattern idents will be bound in staticcatch (let body), so we
-       refresh them here to guarantee binders  uniqueness *)
-    let pat_ids = pat_bound_idents pat in
-    let fresh_ids = List.map (fun id -> id, Ident.rename id) pat_ids in
-    (fresh_ids, alpha_pat fresh_ids pat, lam) :: acc
-  in
-
-  (* sublets were accumulated by 'collect' with the leftmost tuple
-     pattern at the bottom of the list; to respect right-to-left
-     evaluation order for tuples, we must evaluate sublets
-     top-to-bottom. To preserve tail-rec, we will fold_left the
-     reversed list. *)
-  let rev_sublets = List.rev (collect [] pat lam) in
-  let exit =
-    (* build an Ident.tbl to avoid quadratic refreshing costs *)
-    let add t (id, fresh_id) = Ident.add id fresh_id t in
-    let add_ids acc (ids, _pat, _lam) = List.fold_left add acc ids in
-    let tbl = List.fold_left add_ids Ident.empty rev_sublets in
-    let fresh_var id = Lvar (Ident.find_same id tbl) in
-    Lstaticraise(nraise, List.map fresh_var catch_ids)
-  in
-  let push_sublet code (_ids, pat, lam) = simple_for_let loc lam pat code in
-  List.fold_left push_sublet exit rev_sublets
-
-let for_let loc param pat body =
-  match pat.pat_desc with
-  | Tpat_any ->
-      (* This eliminates a useless variable (and stack slot in bytecode)
-         for "let _ = ...". See #6865. *)
-      Lsequence(param, body)
-  | Tpat_var (id, _) ->
-      (* fast path, and keep track of simple bindings to unboxable numbers *)
-      let k = Typeopt.value_kind pat.pat_env pat.pat_type in
-      Llet(Strict, k, id, param, body)
-  | _ ->
-      let opt = ref false in
-      let nraise = next_raise_count () in
-      let catch_ids = pat_bound_idents_full pat in
-      let ids_with_kinds =
-        List.map (fun (id, _, typ) -> id, Typeopt.value_kind pat.pat_env typ)
-          catch_ids
-      in
-      let ids = List.map (fun (id, _, _) -> id) catch_ids in
-      let bind = map_return (assign_pat opt nraise ids loc pat) param in
-      if !opt then Lstaticcatch(bind, (nraise, ids_with_kinds), body)
-      else simple_for_let loc param pat body
-
-(* Handling of tupled functions and matchings *)
-
-(* Easy case since variables are available *)
-let for_tupled_function loc paraml pats_act_list partial =
-  let partial = check_partial_list pats_act_list partial in
-  let raise_num = next_raise_count () in
-  let omegas = [List.map (fun _ -> omega) paraml] in
-  let pm =
-    { cases = pats_act_list;
-      args = List.map (fun id -> (Lvar id, Strict)) paraml ;
-      default = [omegas,raise_num]
-    } in
-  try
-    let (lambda, total) = compile_match None partial
-        (start_ctx (List.length paraml)) pm in
-    check_total total lambda raise_num (partial_function loc)
-  with
-  | Unused -> partial_function loc ()
-
-
-
-let flatten_pattern size p = match p.pat_desc with
-| Tpat_tuple args -> args
-| Tpat_any -> omegas size
-| _ -> raise Cannot_flatten
-
-let rec flatten_pat_line size p k = match p.pat_desc with
-| Tpat_any ->  omegas size::k
-| Tpat_tuple args -> args::k
-| Tpat_or (p1,p2,_) ->  flatten_pat_line size p1 (flatten_pat_line size p2 k)
-| Tpat_alias (p,_,_) -> (* Note: if this 'as' pat is here, then this is a
-                           useless binding, solves PR#3780 *)
-    flatten_pat_line size p k
-| _ -> fatal_error "Matching.flatten_pat_line"
-
-let flatten_cases size cases =
-  List.map
-    (fun (ps,action) -> match ps with
-    | [p] -> flatten_pattern size p,action
-    | _ -> fatal_error "Matching.flatten_case")
-    cases
-
-let flatten_matrix size pss =
-  List.fold_right
-    (fun ps r -> match ps with
-    | [p] -> flatten_pat_line size p r
-    | _   -> fatal_error "Matching.flatten_matrix")
-    pss []
-
-let flatten_def size def =
-  List.map
-    (fun (pss,i) -> flatten_matrix size pss,i)
-    def
-
-let flatten_pm size args pm =
-    {args = args ; cases = flatten_cases size pm.cases ;
-     default = flatten_def size pm.default}
-
-
-let flatten_precompiled size args  pmh = match pmh with
-| Pm pm -> Pm (flatten_pm size args pm)
-| PmOr {body=b ; handlers=hs ; or_matrix=m} ->
-    PmOr
-      {body=flatten_pm size args b ;
-       handlers=
-         List.map
-          (fun (mat,i,vars,pm) -> flatten_matrix size mat,i,vars,pm)
-          hs ;
-       or_matrix=flatten_matrix size m ;}
-| PmVar _ -> assert false
-
-(*
-   compiled_flattened is a ``comp_fun'' argument to comp_match_handlers.
-   Hence it needs a fourth argument, which it ignores
-*)
-
-let compile_flattened repr partial ctx _ pmh = match pmh with
-| Pm pm -> compile_match repr partial ctx pm
-| PmOr {body=b ; handlers=hs} ->
-    let lam, total = compile_match repr partial ctx b in
-    compile_orhandlers (compile_match repr partial) lam total ctx hs
-| PmVar _ -> assert false
-
-let do_for_multiple_match loc paraml pat_act_list partial =
-  let repr = None in
-  let partial = check_partial pat_act_list partial in
-  let raise_num,pm1 =
-    match partial with
-    | Partial ->
-        let raise_num = next_raise_count () in
-        raise_num,
-        { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
-          args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict];
-          default = [[[omega]],raise_num] }
-    | _ ->
-        -1,
-        { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list;
-          args = [Lprim(Pmakeblock(0, Immutable, None), paraml, loc), Strict];
-          default = [] } in
-
-  try
-    try
-(* Once for checking that compilation is possible *)
-      let next, nexts = split_precompile None pm1 in
-
-      let size = List.length paraml
-      and idl = List.map (fun _ -> Ident.create_local "*match*") paraml in
-      let args =  List.map (fun id -> Lvar id, Alias) idl in
-
-      let flat_next = flatten_precompiled size args next
-      and flat_nexts =
-        List.map
-          (fun (e,pm) ->  e,flatten_precompiled size args pm)
-          nexts in
-
-      let lam, total =
-        comp_match_handlers
-          (compile_flattened repr)
-          partial (start_ctx size) () flat_next flat_nexts in
-      List.fold_right2 (bind Strict) idl paraml
-        (match partial with
-        | Partial ->
-            check_total total lam raise_num (partial_function loc)
-        | Total ->
-            assert (jumps_is_empty total) ;
-            lam)
-    with Cannot_flatten ->
-      let (lambda, total) = compile_match None partial (start_ctx 1) pm1 in
-      begin match partial with
-      | Partial ->
-          check_total total lambda raise_num (partial_function loc)
-      | Total ->
-          assert (jumps_is_empty total) ;
-          lambda
-      end
-  with Unused ->
-    assert false (* ; partial_function loc () *)
-
-(* PR#4828: Believe it or not, the 'paraml' argument below
-   may not be side effect free. *)
-
-let param_to_var param = match param with
-| Lvar v -> v,None
-| _ -> Ident.create_local "*match*",Some param
-
-let bind_opt (v,eo) k = match eo with
-| None -> k
-| Some e ->  Lambda.bind Strict v e k
-
-let for_multiple_match loc paraml pat_act_list partial =
-  let v_paraml = List.map param_to_var paraml in
-  let paraml = List.map (fun (v,_) -> Lvar v) v_paraml in
-  List.fold_right bind_opt v_paraml
-    (do_for_multiple_match loc paraml pat_act_list partial)
diff --git a/bytecomp/matching.mli b/bytecomp/matching.mli
deleted file mode 100644
index f29901bd0c..0000000000
--- a/bytecomp/matching.mli
+++ /dev/null
@@ -1,46 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 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.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Compilation of pattern-matching *)
-
-open Typedtree
-open Lambda
-
-
-(* Entry points to match compiler *)
-val for_function:
-        Location.t -> int ref option -> lambda -> (pattern * lambda) list ->
-        partial -> lambda
-val for_trywith:
-        lambda -> (pattern * lambda) list -> lambda
-val for_let:
-        Location.t -> lambda -> pattern -> lambda -> lambda
-val for_multiple_match:
-        Location.t -> lambda list -> (pattern * lambda) list -> partial ->
-        lambda
-
-val for_tupled_function:
-        Location.t -> Ident.t list -> (pattern list * lambda) list ->
-        partial -> lambda
-
-exception Cannot_flatten
-
-val flatten_pattern: int -> pattern -> pattern list
-
-(* Expand stringswitch to  string test tree *)
-val expand_stringswitch:
-    Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda
-
-val inline_lazy_force : lambda -> Location.t -> lambda
diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml
deleted file mode 100644
index e4bb26a686..0000000000
--- a/bytecomp/printlambda.ml
+++ /dev/null
@@ -1,648 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 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 Primitive
-open Types
-open Lambda
-
-
-let rec struct_const ppf = function
-  | Const_base(Const_int n) -> fprintf ppf "%i" n
-  | Const_base(Const_char c) -> fprintf ppf "%C" c
-  | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s
-  | Const_immstring s -> fprintf ppf "#%S" s
-  | Const_base(Const_float f) -> fprintf ppf "%s" f
-  | Const_base(Const_int32 n) -> fprintf ppf "%lil" n
-  | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n
-  | Const_base(Const_nativeint n) -> fprintf ppf "%nin" n
-  | Const_pointer n -> fprintf ppf "%ia" n
-  | Const_block(tag, []) ->
-      fprintf ppf "[%i]" tag
-  | Const_block(tag, sc1::scl) ->
-      let sconsts ppf scl =
-        List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in
-      fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl
-  | Const_float_array [] ->
-      fprintf ppf "[| |]"
-  | Const_float_array (f1 :: fl) ->
-      let floats ppf fl =
-        List.iter (fun f -> fprintf ppf "@ %s" f) fl in
-      fprintf ppf "@[<1>[|@[%s%a@]|]@]" f1 floats fl
-
-let array_kind = function
-  | Pgenarray -> "gen"
-  | Paddrarray -> "addr"
-  | Pintarray -> "int"
-  | Pfloatarray -> "float"
-
-let boxed_integer_name = function
-  | Pnativeint -> "nativeint"
-  | Pint32 -> "int32"
-  | Pint64 -> "int64"
-
-let value_kind ppf = function
-  | Pgenval -> ()
-  | Pintval -> fprintf ppf "[int]"
-  | Pfloatval -> fprintf ppf "[float]"
-  | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi)
-
-let return_kind ppf = function
-  | Pgenval -> ()
-  | Pintval -> fprintf ppf ": int@ "
-  | Pfloatval -> fprintf ppf ": float@ "
-  | Pboxedintval bi -> fprintf ppf ": %s@ " (boxed_integer_name bi)
-
-let field_kind = function
-  | Pgenval -> "*"
-  | Pintval -> "int"
-  | Pfloatval -> "float"
-  | Pboxedintval bi -> boxed_integer_name bi
-
-let print_boxed_integer_conversion ppf bi1 bi2 =
-  fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1)
-
-let boxed_integer_mark name = function
-  | Pnativeint -> Printf.sprintf "Nativeint.%s" name
-  | Pint32 -> Printf.sprintf "Int32.%s" name
-  | Pint64 -> Printf.sprintf "Int64.%s" name
-
-let print_boxed_integer name ppf bi =
-  fprintf ppf "%s" (boxed_integer_mark name bi);;
-
-let print_bigarray name unsafe kind ppf layout =
-  fprintf ppf "Bigarray.%s[%s,%s]"
-    (if unsafe then "unsafe_"^ name else name)
-    (match kind with
-     | Pbigarray_unknown -> "generic"
-     | Pbigarray_float32 -> "float32"
-     | Pbigarray_float64 -> "float64"
-     | Pbigarray_sint8 -> "sint8"
-     | Pbigarray_uint8 -> "uint8"
-     | Pbigarray_sint16 -> "sint16"
-     | Pbigarray_uint16 -> "uint16"
-     | Pbigarray_int32 -> "int32"
-     | Pbigarray_int64 -> "int64"
-     | Pbigarray_caml_int -> "camlint"
-     | Pbigarray_native_int -> "nativeint"
-     | Pbigarray_complex32 -> "complex32"
-     | Pbigarray_complex64 -> "complex64")
-    (match layout with
-    |  Pbigarray_unknown_layout -> "unknown"
-     | Pbigarray_c_layout -> "C"
-     | Pbigarray_fortran_layout -> "Fortran")
-
-let record_rep ppf r =
-  match r with
-  | Record_regular -> fprintf ppf "regular"
-  | Record_inlined i -> fprintf ppf "inlined(%i)" i
-  | Record_unboxed false -> fprintf ppf "unboxed"
-  | Record_unboxed true -> fprintf ppf "inlined(unboxed)"
-  | Record_float -> fprintf ppf "float"
-  | Record_extension path -> fprintf ppf "ext(%a)" Printtyp.path path
-;;
-
-let block_shape ppf shape = match shape with
-  | None | Some [] -> ()
-  | Some l when List.for_all ((=) Pgenval) l -> ()
-  | Some [elt] ->
-      Format.fprintf ppf " (%s)" (field_kind elt)
-  | Some (h :: t) ->
-      Format.fprintf ppf " (%s" (field_kind h);
-      List.iter (fun elt ->
-          Format.fprintf ppf ",%s" (field_kind elt))
-        t;
-      Format.fprintf ppf ")"
-
-let integer_comparison ppf = function
-  | Ceq -> fprintf ppf "=="
-  | Cne -> fprintf ppf "!="
-  | Clt -> fprintf ppf "<"
-  | Cle -> fprintf ppf "<="
-  | Cgt -> fprintf ppf ">"
-  | Cge -> fprintf ppf ">="
-
-let float_comparison ppf = function
-  | CFeq -> fprintf ppf "==."
-  | CFneq -> fprintf ppf "!=."
-  | CFlt -> fprintf ppf "<."
-  | CFnlt -> fprintf ppf "!<."
-  | CFle -> fprintf ppf "<=."
-  | CFnle -> fprintf ppf "!<=."
-  | CFgt -> fprintf ppf ">."
-  | CFngt -> fprintf ppf "!>."
-  | CFge -> fprintf ppf ">=."
-  | CFnge -> fprintf ppf "!>=."
-
-let primitive ppf = function
-  | Pidentity -> fprintf ppf "id"
-  | Pbytes_to_string -> fprintf ppf "bytes_to_string"
-  | Pbytes_of_string -> fprintf ppf "bytes_of_string"
-  | Pignore -> fprintf ppf "ignore"
-  | Prevapply -> fprintf ppf "revapply"
-  | Pdirapply -> fprintf ppf "dirapply"
-  | Pgetglobal id -> fprintf ppf "global %a" Ident.print id
-  | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id
-  | Pmakeblock(tag, Immutable, shape) ->
-      fprintf ppf "makeblock %i%a" tag block_shape shape
-  | Pmakeblock(tag, Mutable, shape) ->
-      fprintf ppf "makemutable %i%a" tag 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" record_rep rep size
-  | Pccall p -> fprintf ppf "%s" p.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) -> 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) -> 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)
-  | Pctconst c ->
-     let const_name = match c with
-       | Big_endian -> "big_endian"
-       | Word_size -> "word_size"
-       | Int_size -> "int_size"
-       | Max_wosize -> "max_wosize"
-       | Ostype_unix -> "ostype_unix"
-       | Ostype_win32 -> "ostype_win32"
-       | Ostype_cygwin -> "ostype_cygwin"
-       | Backend_type -> "backend_type" in
-     fprintf ppf "sys.constant_%s" const_name
-  | 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) -> print_boxed_integer_conversion ppf bi1 bi2
-  | 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) ->
-      print_bigarray "get" unsafe kind ppf layout
-  | Pbigarrayset(unsafe, _n, kind, layout) ->
-      print_bigarray "set" unsafe kind ppf layout
-  | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n
-  | Pstring_load_16(unsafe) ->
-     if unsafe then fprintf ppf "string.unsafe_get16"
-     else fprintf ppf "string.get16"
-  | Pstring_load_32(unsafe) ->
-     if unsafe then fprintf ppf "string.unsafe_get32"
-     else fprintf ppf "string.get32"
-  | Pstring_load_64(unsafe) ->
-     if unsafe then fprintf ppf "string.unsafe_get64"
-     else fprintf ppf "string.get64"
-  | Pbytes_load_16(unsafe) ->
-     if unsafe then fprintf ppf "bytes.unsafe_get16"
-     else fprintf ppf "bytes.get16"
-  | Pbytes_load_32(unsafe) ->
-     if unsafe then fprintf ppf "bytes.unsafe_get32"
-     else fprintf ppf "bytes.get32"
-  | Pbytes_load_64(unsafe) ->
-     if unsafe then fprintf ppf "bytes.unsafe_get64"
-     else fprintf ppf "bytes.get64"
-  | Pbytes_set_16(unsafe) ->
-     if unsafe then fprintf ppf "bytes.unsafe_set16"
-     else fprintf ppf "bytes.set16"
-  | Pbytes_set_32(unsafe) ->
-     if unsafe then fprintf ppf "bytes.unsafe_set32"
-     else fprintf ppf "bytes.set32"
-  | Pbytes_set_64(unsafe) ->
-     if unsafe then fprintf ppf "bytes.unsafe_set64"
-     else fprintf ppf "bytes.set64"
-  | Pbigstring_load_16(unsafe) ->
-     if unsafe then fprintf ppf "bigarray.array1.unsafe_get16"
-     else fprintf ppf "bigarray.array1.get16"
-  | Pbigstring_load_32(unsafe) ->
-     if unsafe then fprintf ppf "bigarray.array1.unsafe_get32"
-     else fprintf ppf "bigarray.array1.get32"
-  | Pbigstring_load_64(unsafe) ->
-     if unsafe then fprintf ppf "bigarray.array1.unsafe_get64"
-     else fprintf ppf "bigarray.array1.get64"
-  | Pbigstring_set_16(unsafe) ->
-     if unsafe then fprintf ppf "bigarray.array1.unsafe_set16"
-     else fprintf ppf "bigarray.array1.set16"
-  | Pbigstring_set_32(unsafe) ->
-     if unsafe then fprintf ppf "bigarray.array1.unsafe_set32"
-     else fprintf ppf "bigarray.array1.set32"
-  | Pbigstring_set_64(unsafe) ->
-     if unsafe then fprintf ppf "bigarray.array1.unsafe_set64"
-     else fprintf ppf "bigarray.array1.set64"
-  | Pbswap16 -> fprintf ppf "bswap16"
-  | Pbbswap(bi) -> print_boxed_integer "bswap" ppf bi
-  | Pint_as_pointer -> fprintf ppf "int_as_pointer"
-  | Popaque -> fprintf ppf "opaque"
-
-let name_of_primitive = function
-  | Pidentity -> "Pidentity"
-  | Pbytes_of_string -> "Pbytes_of_string"
-  | Pbytes_to_string -> "Pbytes_to_string"
-  | Pignore -> "Pignore"
-  | Prevapply -> "Prevapply"
-  | Pdirapply -> "Pdirapply"
-  | Pgetglobal _ -> "Pgetglobal"
-  | Psetglobal _ -> "Psetglobal"
-  | Pmakeblock _ -> "Pmakeblock"
-  | Pfield _ -> "Pfield"
-  | Pfield_computed -> "Pfield_computed"
-  | Psetfield _ -> "Psetfield"
-  | Psetfield_computed _ -> "Psetfield_computed"
-  | Pfloatfield _ -> "Pfloatfield"
-  | Psetfloatfield _ -> "Psetfloatfield"
-  | Pduprecord _ -> "Pduprecord"
-  | Pccall _ -> "Pccall"
-  | Praise _ -> "Praise"
-  | Psequand -> "Psequand"
-  | Psequor -> "Psequor"
-  | Pnot -> "Pnot"
-  | Pnegint -> "Pnegint"
-  | Paddint -> "Paddint"
-  | Psubint -> "Psubint"
-  | Pmulint -> "Pmulint"
-  | Pdivint _ -> "Pdivint"
-  | Pmodint _ -> "Pmodint"
-  | Pandint -> "Pandint"
-  | Porint -> "Porint"
-  | Pxorint -> "Pxorint"
-  | Plslint -> "Plslint"
-  | Plsrint -> "Plsrint"
-  | Pasrint -> "Pasrint"
-  | Pintcomp _ -> "Pintcomp"
-  | Poffsetint _ -> "Poffsetint"
-  | Poffsetref _ -> "Poffsetref"
-  | Pintoffloat -> "Pintoffloat"
-  | Pfloatofint -> "Pfloatofint"
-  | Pnegfloat -> "Pnegfloat"
-  | Pabsfloat -> "Pabsfloat"
-  | Paddfloat -> "Paddfloat"
-  | Psubfloat -> "Psubfloat"
-  | Pmulfloat -> "Pmulfloat"
-  | Pdivfloat -> "Pdivfloat"
-  | Pfloatcomp _ -> "Pfloatcomp"
-  | Pstringlength -> "Pstringlength"
-  | Pstringrefu -> "Pstringrefu"
-  | Pstringrefs -> "Pstringrefs"
-  | Pbyteslength -> "Pbyteslength"
-  | Pbytesrefu -> "Pbytesrefu"
-  | Pbytessetu -> "Pbytessetu"
-  | Pbytesrefs -> "Pbytesrefs"
-  | Pbytessets -> "Pbytessets"
-  | Parraylength _ -> "Parraylength"
-  | Pmakearray _ -> "Pmakearray"
-  | Pduparray _ -> "Pduparray"
-  | Parrayrefu _ -> "Parrayrefu"
-  | Parraysetu _ -> "Parraysetu"
-  | Parrayrefs _ -> "Parrayrefs"
-  | Parraysets _ -> "Parraysets"
-  | Pctconst _ -> "Pctconst"
-  | Pisint -> "Pisint"
-  | Pisout -> "Pisout"
-  | Pbintofint _ -> "Pbintofint"
-  | Pintofbint _ -> "Pintofbint"
-  | Pcvtbint _ -> "Pcvtbint"
-  | Pnegbint _ -> "Pnegbint"
-  | Paddbint _ -> "Paddbint"
-  | Psubbint _ -> "Psubbint"
-  | Pmulbint _ -> "Pmulbint"
-  | Pdivbint _ -> "Pdivbint"
-  | Pmodbint _ -> "Pmodbint"
-  | Pandbint _ -> "Pandbint"
-  | Porbint _ -> "Porbint"
-  | Pxorbint _ -> "Pxorbint"
-  | Plslbint _ -> "Plslbint"
-  | Plsrbint _ -> "Plsrbint"
-  | Pasrbint _ -> "Pasrbint"
-  | Pbintcomp _ -> "Pbintcomp"
-  | Pbigarrayref _ -> "Pbigarrayref"
-  | Pbigarrayset _ -> "Pbigarrayset"
-  | Pbigarraydim _ -> "Pbigarraydim"
-  | Pstring_load_16 _ -> "Pstring_load_16"
-  | Pstring_load_32 _ -> "Pstring_load_32"
-  | Pstring_load_64 _ -> "Pstring_load_64"
-  | Pbytes_load_16 _ -> "Pbytes_load_16"
-  | Pbytes_load_32 _ -> "Pbytes_load_32"
-  | Pbytes_load_64 _ -> "Pbytes_load_64"
-  | Pbytes_set_16 _ -> "Pbytes_set_16"
-  | Pbytes_set_32 _ -> "Pbytes_set_32"
-  | Pbytes_set_64 _ -> "Pbytes_set_64"
-  | Pbigstring_load_16 _ -> "Pbigstring_load_16"
-  | Pbigstring_load_32 _ -> "Pbigstring_load_32"
-  | Pbigstring_load_64 _ -> "Pbigstring_load_64"
-  | Pbigstring_set_16 _ -> "Pbigstring_set_16"
-  | Pbigstring_set_32 _ -> "Pbigstring_set_32"
-  | Pbigstring_set_64 _ -> "Pbigstring_set_64"
-  | Pbswap16 -> "Pbswap16"
-  | Pbbswap _ -> "Pbbswap"
-  | Pint_as_pointer -> "Pint_as_pointer"
-  | Popaque -> "Popaque"
-
-let function_attribute ppf { inline; specialise; local; is_a_functor; stub } =
-  if is_a_functor then
-    fprintf ppf "is_a_functor@ ";
-  if stub then
-    fprintf ppf "stub@ ";
-  begin match inline with
-  | Default_inline -> ()
-  | Always_inline -> fprintf ppf "always_inline@ "
-  | Never_inline -> fprintf ppf "never_inline@ "
-  | Unroll i -> fprintf ppf "unroll(%i)@ " i
-  end;
-  begin match specialise with
-  | Default_specialise -> ()
-  | Always_specialise -> fprintf ppf "always_specialise@ "
-  | Never_specialise -> fprintf ppf "never_specialise@ "
-  end;
-  begin match local with
-  | Default_local -> ()
-  | Always_local -> fprintf ppf "always_local@ "
-  | Never_local -> fprintf ppf "never_local@ "
-  end
-
-let apply_tailcall_attribute ppf tailcall =
-  if tailcall then
-    fprintf ppf " @@tailcall"
-
-let apply_inlined_attribute ppf = function
-  | Default_inline -> ()
-  | Always_inline -> fprintf ppf " always_inline"
-  | Never_inline -> fprintf ppf " never_inline"
-  | Unroll i -> fprintf ppf " never_inline(%i)" i
-
-let apply_specialised_attribute ppf = function
-  | Default_specialise -> ()
-  | Always_specialise -> fprintf ppf " always_specialise"
-  | Never_specialise -> fprintf ppf " never_specialise"
-
-let rec lam ppf = function
-  | Lvar id ->
-      Ident.print ppf id
-  | Lconst cst ->
-      struct_const ppf cst
-  | Lapply ap ->
-      let lams ppf largs =
-        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
-      fprintf ppf "@[<2>(apply@ %a%a%a%a%a)@]" lam ap.ap_func lams ap.ap_args
-        apply_tailcall_attribute ap.ap_should_be_tailcall
-        apply_inlined_attribute ap.ap_inlined
-        apply_specialised_attribute ap.ap_specialised
-  | Lfunction{kind; params; return; body; attr} ->
-      let pr_params ppf params =
-        match kind with
-        | Curried ->
-            List.iter (fun (param, k) ->
-                fprintf ppf "@ %a%a" Ident.print param value_kind k) params
-        | Tupled ->
-            fprintf ppf " (";
-            let first = ref true in
-            List.iter
-              (fun (param, k) ->
-                if !first then first := false else fprintf ppf ",@ ";
-                Ident.print ppf param;
-                value_kind ppf k)
-              params;
-            fprintf ppf ")" in
-      fprintf ppf "@[<2>(function%a@ %a%a%a)@]" pr_params params
-        function_attribute attr return_kind return lam body
-  | Llet(str, k, id, arg, body) ->
-      let kind = function
-          Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v"
-      in
-      let rec letbody = function
-        | Llet(str, k, id, arg, body) ->
-            fprintf ppf "@ @[<2>%a =%s%a@ %a@]"
-              Ident.print id (kind str) value_kind k lam arg;
-            letbody body
-        | expr -> expr in
-      fprintf ppf "@[<2>(let@ @[<hv 1>(@[<2>%a =%s%a@ %a@]"
-        Ident.print id (kind str) value_kind k lam arg;
-      let expr = letbody body in
-      fprintf ppf ")@]@ %a)@]" lam expr
-  | Lletrec(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@]" Ident.print id lam l)
-          id_arg_list in
-      fprintf ppf
-        "@[<2>(letrec@ (@[<hv 1>%a@])@ %a)@]" bindings id_arg_list lam body
-  | Lprim(prim, largs, _) ->
-      let lams ppf largs =
-        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
-      fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs
-  | Lswitch(larg, sw, _loc) ->
-      let switch ppf sw =
-        let spc = ref false in
-        List.iter
-         (fun (n, l) ->
-           if !spc then fprintf ppf "@ " else spc := true;
-           fprintf ppf "@[<hv 1>case int %i:@ %a@]" n lam l)
-         sw.sw_consts;
-        List.iter
-          (fun (n, l) ->
-            if !spc then fprintf ppf "@ " else spc := true;
-            fprintf ppf "@[<hv 1>case tag %i:@ %a@]" n lam l)
-          sw.sw_blocks ;
-        begin match sw.sw_failaction with
-        | None  -> ()
-        | Some l ->
-            if !spc then fprintf ppf "@ " else spc := true;
-            fprintf ppf "@[<hv 1>default:@ %a@]" lam l
-        end in
-      fprintf ppf
-       "@[<1>(%s %a@ @[<v 0>%a@])@]"
-       (match sw.sw_failaction with None -> "switch*" | _ -> "switch")
-       lam larg switch sw
-  | Lstringswitch(arg, cases, default, _) ->
-      let switch ppf cases =
-        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)
-          cases;
-        begin match default with
-        | Some default ->
-            if !spc then fprintf ppf "@ " else spc := true;
-            fprintf ppf "@[<hv 1>default:@ %a@]" lam default
-        | None -> ()
-        end in
-      fprintf ppf
-       "@[<1>(stringswitch %a@ @[<v 0>%a@])@]" lam arg switch cases
-  | Lstaticraise (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;
-  | Lstaticcatch(lbody, (i, vars), 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" Ident.print x value_kind k)
-             vars
-        )
-        vars
-        lam lhandler
-  | Ltrywith(lbody, param, lhandler) ->
-      fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]"
-        lam lbody Ident.print param lam lhandler
-  | Lifthenelse(lcond, lif, lelse) ->
-      fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse
-  | Lsequence(l1, l2) ->
-      fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2
-  | Lwhile(lcond, lbody) ->
-      fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody
-  | Lfor(param, lo, hi, dir, body) ->
-      fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]"
-       Ident.print param lam lo
-       (match dir with Upto -> "to" | Downto -> "downto")
-       lam hi lam body
-  | Lassign(id, expr) ->
-      fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr
-  | Lsend (k, met, obj, largs, _) ->
-      let args ppf largs =
-        List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in
-      let kind =
-        if k = Self then "self" else if k = Cached then "cache" else "" in
-      fprintf ppf "@[<2>(send%s@ %a@ %a%a)@]" kind lam obj lam met args largs
-  | Levent(expr, ev) ->
-      let kind =
-       match ev.lev_kind with
-       | Lev_before -> "before"
-       | Lev_after _  -> "after"
-       | Lev_function -> "funct-body"
-       | Lev_pseudo -> "pseudo"
-       | Lev_module_definition ident ->
-         Format.asprintf "module-defn(%a)" Ident.print ident
-      in
-      fprintf ppf "@[<2>(%s %s(%i)%s:%i-%i@ %a)@]" kind
-              ev.lev_loc.Location.loc_start.Lexing.pos_fname
-              ev.lev_loc.Location.loc_start.Lexing.pos_lnum
-              (if ev.lev_loc.Location.loc_ghost then "<ghost>" else "")
-              ev.lev_loc.Location.loc_start.Lexing.pos_cnum
-              ev.lev_loc.Location.loc_end.Lexing.pos_cnum
-              lam expr
-  | Lifused(id, expr) ->
-      fprintf ppf "@[<2>(ifused@ %a@ %a)@]" Ident.print id lam expr
-
-and sequence ppf = function
-  | Lsequence(l1, l2) ->
-      fprintf ppf "%a@ %a" sequence l1 sequence l2
-  | l ->
-      lam ppf l
-
-let structured_constant = struct_const
-
-let lambda = lam
-
-let program ppf { code } = lambda ppf code
diff --git a/bytecomp/printlambda.mli b/bytecomp/printlambda.mli
deleted file mode 100644
index 7dab5229ac..0000000000
--- a/bytecomp/printlambda.mli
+++ /dev/null
@@ -1,32 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 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 Lambda
-
-open Format
-
-val integer_comparison: formatter -> integer_comparison -> unit
-val float_comparison: formatter -> float_comparison -> unit
-val structured_constant: formatter -> structured_constant -> unit
-val lambda: formatter -> lambda -> unit
-val program: formatter -> program -> unit
-val primitive: formatter -> primitive -> unit
-val name_of_primitive : primitive -> string
-val value_kind : formatter -> value_kind -> unit
-val block_shape : formatter -> value_kind list option -> unit
-val record_rep : formatter -> Types.record_representation -> unit
-val print_bigarray :
-  string -> bool -> Lambda.bigarray_kind -> formatter ->
-  Lambda.bigarray_layout -> unit
diff --git a/bytecomp/runtimedef.mli b/bytecomp/runtimedef.mli
deleted file mode 100644
index 3baabb643b..0000000000
--- a/bytecomp/runtimedef.mli
+++ /dev/null
@@ -1,19 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 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.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Values and functions known and/or provided by the runtime system *)
-
-val builtin_exceptions: string array
-val builtin_primitives: string array
diff --git a/bytecomp/simplif.ml b/bytecomp/simplif.ml
deleted file mode 100644
index d57171e8b1..0000000000
--- a/bytecomp/simplif.ml
+++ /dev/null
@@ -1,854 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 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.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Elimination of useless Llet(Alias) bindings.
-   Also transform let-bound references into variables. *)
-
-open Asttypes
-open Lambda
-
-(* To transform let-bound references into variables *)
-
-exception Real_reference
-
-let rec eliminate_ref id = function
-    Lvar v as lam ->
-      if Ident.same v id then raise Real_reference else lam
-  | Lconst _ as lam -> lam
-  | Lapply ap ->
-      Lapply{ap with ap_func = eliminate_ref id ap.ap_func;
-                     ap_args = List.map (eliminate_ref id) ap.ap_args}
-  | Lfunction _ as lam ->
-      if Ident.Set.mem id (free_variables lam)
-      then raise Real_reference
-      else lam
-  | Llet(str, kind, v, e1, e2) ->
-      Llet(str, kind, v, eliminate_ref id e1, eliminate_ref id e2)
-  | Lletrec(idel, e2) ->
-      Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel,
-              eliminate_ref id e2)
-  | Lprim(Pfield 0, [Lvar v], _) when Ident.same v id ->
-      Lvar id
-  | Lprim(Psetfield(0, _, _), [Lvar v; e], _) when Ident.same v id ->
-      Lassign(id, eliminate_ref id e)
-  | Lprim(Poffsetref delta, [Lvar v], loc) when Ident.same v id ->
-      Lassign(id, Lprim(Poffsetint delta, [Lvar id], loc))
-  | Lprim(p, el, loc) ->
-      Lprim(p, List.map (eliminate_ref id) el, loc)
-  | Lswitch(e, sw, loc) ->
-      Lswitch(eliminate_ref id e,
-        {sw_numconsts = sw.sw_numconsts;
-         sw_consts =
-            List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_consts;
-         sw_numblocks = sw.sw_numblocks;
-         sw_blocks =
-            List.map (fun (n, e) -> (n, eliminate_ref id e)) sw.sw_blocks;
-         sw_failaction =
-            Misc.may_map (eliminate_ref id) sw.sw_failaction; },
-        loc)
-  | Lstringswitch(e, sw, default, loc) ->
-      Lstringswitch
-        (eliminate_ref id e,
-         List.map (fun (s, e) -> (s, eliminate_ref id e)) sw,
-         Misc.may_map (eliminate_ref id) default, loc)
-  | Lstaticraise (i,args) ->
-      Lstaticraise (i,List.map (eliminate_ref id) args)
-  | Lstaticcatch(e1, i, e2) ->
-      Lstaticcatch(eliminate_ref id e1, i, eliminate_ref id e2)
-  | Ltrywith(e1, v, e2) ->
-      Ltrywith(eliminate_ref id e1, v, eliminate_ref id e2)
-  | Lifthenelse(e1, e2, e3) ->
-      Lifthenelse(eliminate_ref id e1,
-                  eliminate_ref id e2,
-                  eliminate_ref id e3)
-  | Lsequence(e1, e2) ->
-      Lsequence(eliminate_ref id e1, eliminate_ref id e2)
-  | Lwhile(e1, e2) ->
-      Lwhile(eliminate_ref id e1, eliminate_ref id e2)
-  | Lfor(v, e1, e2, dir, e3) ->
-      Lfor(v, eliminate_ref id e1, eliminate_ref id e2,
-           dir, eliminate_ref id e3)
-  | Lassign(v, e) ->
-      Lassign(v, eliminate_ref id e)
-  | Lsend(k, m, o, el, loc) ->
-      Lsend(k, eliminate_ref id m, eliminate_ref id o,
-            List.map (eliminate_ref id) el, loc)
-  | Levent(l, ev) ->
-      Levent(eliminate_ref id l, ev)
-  | Lifused(v, e) ->
-      Lifused(v, eliminate_ref id e)
-
-(* Simplification of exits *)
-
-type exit = {
-  mutable count: int;
-  mutable max_depth: int;
-}
-
-let simplify_exits lam =
-
-  (* Count occurrences of (exit n ...) statements *)
-  let exits = Hashtbl.create 17 in
-
-  let try_depth = ref 0 in
-
-  let get_exit i =
-    try Hashtbl.find exits i
-    with Not_found -> {count = 0; max_depth = 0}
-
-  and incr_exit i nb d =
-    match Hashtbl.find_opt exits i with
-    | Some r ->
-        r.count <- r.count + nb;
-        r.max_depth <- max r.max_depth d
-    | None ->
-        let r = {count = nb; max_depth = d} in
-        Hashtbl.add exits i r
-  in
-
-  let rec count = function
-  | (Lvar _| Lconst _) -> ()
-  | Lapply ap -> count ap.ap_func; List.iter count ap.ap_args
-  | Lfunction {body} -> count body
-  | Llet(_str, _kind, _v, l1, l2) ->
-      count l2; count l1
-  | Lletrec(bindings, body) ->
-      List.iter (fun (_v, l) -> count l) bindings;
-      count body
-  | Lprim(_p, ll, _) -> List.iter count ll
-  | Lswitch(l, sw, _loc) ->
-      count_default sw ;
-      count l;
-      List.iter (fun (_, l) -> count l) sw.sw_consts;
-      List.iter (fun (_, l) -> count l) sw.sw_blocks
-  | Lstringswitch(l, sw, d, _) ->
-      count l;
-      List.iter (fun (_, l) -> count l) sw;
-      begin match  d with
-      | None -> ()
-      | Some d -> match sw with
-        | []|[_] -> count d
-        | _ -> count d; count d (* default will get replicated *)
-      end
-  | Lstaticraise (i,ls) -> incr_exit i 1 !try_depth; List.iter count ls
-  | Lstaticcatch (l1,(i,[]),Lstaticraise (j,[])) ->
-      (* i will be replaced by j in l1, so each occurrence of i in l1
-         increases j's ref count *)
-      count l1 ;
-      let ic = get_exit i in
-      incr_exit j ic.count (max !try_depth ic.max_depth)
-  | Lstaticcatch(l1, (i,_), l2) ->
-      count l1;
-      (* If l1 does not contain (exit i),
-         l2 will be removed, so don't count its exits *)
-      if (get_exit i).count > 0 then
-        count l2
-  | Ltrywith(l1, _v, l2) -> incr try_depth; count l1; decr try_depth; count l2
-  | Lifthenelse(l1, l2, l3) -> count l1; count l2; count l3
-  | Lsequence(l1, l2) -> count l1; count l2
-  | Lwhile(l1, l2) -> count l1; count l2
-  | Lfor(_, l1, l2, _dir, l3) -> count l1; count l2; count l3
-  | Lassign(_v, l) -> count l
-  | Lsend(_k, m, o, ll, _) -> List.iter count (m::o::ll)
-  | Levent(l, _) -> count l
-  | Lifused(_v, l) -> count l
-
-  and count_default sw = match sw.sw_failaction with
-  | None -> ()
-  | Some al ->
-      let nconsts = List.length sw.sw_consts
-      and nblocks = List.length sw.sw_blocks in
-      if
-        nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks
-      then begin (* default action will occur twice in native code *)
-        count al ; count al
-      end else begin (* default action will occur once *)
-        assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ;
-        count al
-      end
-  in
-  count lam;
-  assert(!try_depth = 0);
-
-  (*
-     Second pass simplify  ``catch body with (i ...) handler''
-      - if (exit i ...) does not occur in body, suppress catch
-      - if (exit i ...) occurs exactly once in body,
-        substitute it with handler
-      - If handler is a single variable, replace (exit i ..) with it
-   Note:
-    In ``catch body with (i x1 .. xn) handler''
-     Substituted expression is
-      let y1 = x1 and ... yn = xn in
-      handler[x1 <- y1 ; ... ; xn <- yn]
-     For the sake of preserving the uniqueness  of bound variables.
-     (No alpha conversion of ``handler'' is presently needed, since
-     substitution of several ``(exit i ...)''
-     occurs only when ``handler'' is a variable.)
-  *)
-
-  let subst = Hashtbl.create 17 in
-
-  let rec simplif = function
-  | (Lvar _|Lconst _) as l -> l
-  | Lapply ap ->
-      Lapply{ap with ap_func = simplif ap.ap_func;
-                     ap_args = List.map simplif ap.ap_args}
-  | Lfunction{kind; params; return; body = l; attr; loc} ->
-     Lfunction{kind; params; return; body = simplif l; attr; loc}
-  | Llet(str, kind, v, l1, l2) -> Llet(str, kind, v, simplif l1, simplif l2)
-  | Lletrec(bindings, body) ->
-      Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
-  | Lprim(p, ll, loc) -> begin
-    let ll = List.map simplif ll in
-    match p, ll with
-        (* Simplify %revapply, for n-ary functions with n > 1 *)
-      | Prevapply, [x; Lapply ap]
-      | Prevapply, [x; Levent (Lapply ap,_)] ->
-        Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc}
-      | Prevapply, [x; f] -> Lapply {ap_should_be_tailcall=false;
-                                     ap_loc=loc;
-                                     ap_func=f;
-                                     ap_args=[x];
-                                     ap_inlined=Default_inline;
-                                     ap_specialised=Default_specialise}
-
-        (* Simplify %apply, for n-ary functions with n > 1 *)
-      | Pdirapply, [Lapply ap; x]
-      | Pdirapply, [Levent (Lapply ap,_); x] ->
-        Lapply {ap with ap_args = ap.ap_args @ [x]; ap_loc = loc}
-      | Pdirapply, [f; x] -> Lapply {ap_should_be_tailcall=false;
-                                     ap_loc=loc;
-                                     ap_func=f;
-                                     ap_args=[x];
-                                     ap_inlined=Default_inline;
-                                     ap_specialised=Default_specialise}
-        (* Simplify %identity *)
-      | Pidentity, [e] -> e
-
-        (* Simplify Obj.with_tag *)
-      | Pccall { Primitive.prim_name = "caml_obj_with_tag"; _ },
-        [Lconst (Const_base (Const_int tag));
-         Lprim (Pmakeblock (_, mut, shape), fields, loc)] ->
-         Lprim (Pmakeblock(tag, mut, shape), fields, loc)
-      | Pccall { Primitive.prim_name = "caml_obj_with_tag"; _ },
-        [Lconst (Const_base (Const_int tag));
-         Lconst (Const_block (_, fields))] ->
-         Lconst (Const_block (tag, fields))
-
-      | _ -> Lprim(p, ll, loc)
-     end
-  | Lswitch(l, sw, loc) ->
-      let new_l = simplif l
-      and new_consts =  List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
-      and new_blocks =  List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks
-      and new_fail = Misc.may_map simplif sw.sw_failaction in
-      Lswitch
-        (new_l,
-         {sw with sw_consts = new_consts ; sw_blocks = new_blocks;
-                  sw_failaction = new_fail},
-         loc)
-  | Lstringswitch(l,sw,d,loc) ->
-      Lstringswitch
-        (simplif l,List.map (fun (s,l) -> s,simplif l) sw,
-         Misc.may_map simplif d,loc)
-  | Lstaticraise (i,[]) as l ->
-      begin try
-        let _,handler =  Hashtbl.find subst i in
-        handler
-      with
-      | Not_found -> l
-      end
-  | Lstaticraise (i,ls) ->
-      let ls = List.map simplif ls in
-      begin try
-        let xs,handler =  Hashtbl.find subst i in
-        let ys = List.map (fun (x, k) -> Ident.rename x, k) xs in
-        let env =
-          List.fold_right2
-            (fun (x, _) (y, _) env -> Ident.Map.add x y env)
-            xs ys Ident.Map.empty
-        in
-        List.fold_right2
-          (fun (y, kind) l r -> Llet (Strict, kind, y, l, r))
-          ys ls (Lambda.rename env handler)
-      with
-      | Not_found -> Lstaticraise (i,ls)
-      end
-  | Lstaticcatch (l1,(i,[]),(Lstaticraise (_j,[]) as l2)) ->
-      Hashtbl.add subst i ([],simplif l2) ;
-      simplif l1
-  | Lstaticcatch (l1,(i,xs),l2) ->
-      let {count; max_depth} = get_exit i in
-      if count = 0 then
-        (* Discard staticcatch: not matching exit *)
-        simplif l1
-      else if count = 1 && max_depth <= !try_depth then begin
-        (* Inline handler if there is a single occurrence and it is not
-           nested within an inner try..with *)
-        assert(max_depth = !try_depth);
-        Hashtbl.add subst i (xs,simplif l2);
-        simplif l1
-      end else
-        Lstaticcatch (simplif l1, (i,xs), simplif l2)
-  | Ltrywith(l1, v, l2) ->
-      incr try_depth;
-      let l1 = simplif l1 in
-      decr try_depth;
-      Ltrywith(l1, v, simplif l2)
-  | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3)
-  | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2)
-  | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2)
-  | Lfor(v, l1, l2, dir, l3) ->
-      Lfor(v, simplif l1, simplif l2, dir, simplif l3)
-  | Lassign(v, l) -> Lassign(v, simplif l)
-  | Lsend(k, m, o, ll, loc) ->
-      Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
-  | Levent(l, ev) -> Levent(simplif l, ev)
-  | Lifused(v, l) -> Lifused (v,simplif l)
-  in
-  simplif lam
-
-(* Compile-time beta-reduction of functions immediately applied:
-      Lapply(Lfunction(Curried, params, body), args, loc) ->
-        let paramN = argN in ... let param1 = arg1 in body
-      Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) ->
-        let paramN = argN in ... let param1 = arg1 in body
-   Assumes |args| = |params|.
-*)
-
-let beta_reduce params body args =
-  List.fold_left2 (fun l (param, kind) arg -> Llet(Strict, kind, param, arg, l))
-                  body params args
-
-(* Simplification of lets *)
-
-let simplify_lets lam =
-
-  (* Disable optimisations for bytecode compilation with -g flag *)
-  let optimize = !Clflags.native_code || not !Clflags.debug in
-
-  (* First pass: count the occurrences of all let-bound identifiers *)
-
-  let occ = (Hashtbl.create 83: (Ident.t, int ref) Hashtbl.t) in
-  (* The global table [occ] associates to each let-bound identifier
-     the number of its uses (as a reference):
-     - 0 if never used
-     - 1 if used exactly once in and not under a lambda or within a loop
-     - > 1 if used several times or under a lambda or within a loop.
-     The local table [bv] associates to each locally-let-bound variable
-     its reference count, as above.  [bv] is enriched at let bindings
-     but emptied when crossing lambdas and loops. *)
-
-  (* Current use count of a variable. *)
-  let count_var v =
-    try
-      !(Hashtbl.find occ v)
-    with Not_found ->
-      0
-
-  (* Entering a [let].  Returns updated [bv]. *)
-  and bind_var bv v =
-    let r = ref 0 in
-    Hashtbl.add occ v r;
-    Ident.Map.add v r bv
-
-  (* Record a use of a variable *)
-  and use_var bv v n =
-    try
-      let r = Ident.Map.find v bv in r := !r + n
-    with Not_found ->
-      (* v is not locally bound, therefore this is a use under a lambda
-         or within a loop.  Increase use count by 2 -- enough so
-         that single-use optimizations will not apply. *)
-    try
-      let r = Hashtbl.find occ v in r := !r + 2
-    with Not_found ->
-      (* Not a let-bound variable, ignore *)
-      () in
-
-  let rec count bv = function
-  | Lconst _ -> ()
-  | Lvar v ->
-      use_var bv v 1
-  | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args}
-    when optimize && List.length params = List.length args ->
-      count bv (beta_reduce params body args)
-  | Lapply{ap_func = Lfunction{kind = Tupled; params; body};
-           ap_args = [Lprim(Pmakeblock _, args, _)]}
-    when optimize && List.length params = List.length args ->
-      count bv (beta_reduce params body args)
-  | Lapply{ap_func = l1; ap_args = ll} ->
-      count bv l1; List.iter (count bv) ll
-  | Lfunction {body} ->
-      count Ident.Map.empty body
-  | Llet(_str, _k, v, Lvar w, l2) when optimize ->
-      (* v will be replaced by w in l2, so each occurrence of v in l2
-         increases w's refcount *)
-      count (bind_var bv v) l2;
-      use_var bv w (count_var v)
-  | Llet(str, _kind, v, l1, l2) ->
-      count (bind_var bv v) l2;
-      (* If v is unused, l1 will be removed, so don't count its variables *)
-      if str = Strict || count_var v > 0 then count bv l1
-  | Lletrec(bindings, body) ->
-      List.iter (fun (_v, l) -> count bv l) bindings;
-      count bv body
-  | Lprim(_p, ll, _) -> List.iter (count bv) ll
-  | Lswitch(l, sw, _loc) ->
-      count_default bv sw ;
-      count bv l;
-      List.iter (fun (_, l) -> count bv l) sw.sw_consts;
-      List.iter (fun (_, l) -> count bv l) sw.sw_blocks
-  | Lstringswitch(l, sw, d, _) ->
-      count bv l ;
-      List.iter (fun (_, l) -> count bv l) sw ;
-      begin match d with
-      | Some d ->
-          begin match sw with
-          | []|[_] -> count bv d
-          | _ -> count bv d ; count bv d
-          end
-      | None -> ()
-      end
-  | Lstaticraise (_i,ls) -> List.iter (count bv) ls
-  | Lstaticcatch(l1, _, l2) -> count bv l1; count bv l2
-  | Ltrywith(l1, _v, l2) -> count bv l1; count bv l2
-  | Lifthenelse(l1, l2, l3) -> count bv l1; count bv l2; count bv l3
-  | Lsequence(l1, l2) -> count bv l1; count bv l2
-  | Lwhile(l1, l2) -> count Ident.Map.empty l1; count Ident.Map.empty l2
-  | Lfor(_, l1, l2, _dir, l3) ->
-      count bv l1; count bv l2; count Ident.Map.empty l3
-  | Lassign(_v, l) ->
-      (* Lalias-bound variables are never assigned, so don't increase
-         v's refcount *)
-      count bv l
-  | Lsend(_, m, o, ll, _) -> List.iter (count bv) (m::o::ll)
-  | Levent(l, _) -> count bv l
-  | Lifused(v, l) ->
-      if count_var v > 0 then count bv l
-
-  and count_default bv sw = match sw.sw_failaction with
-  | None -> ()
-  | Some al ->
-      let nconsts = List.length sw.sw_consts
-      and nblocks = List.length sw.sw_blocks in
-      if
-        nconsts < sw.sw_numconsts && nblocks < sw.sw_numblocks
-      then begin (* default action will occur twice in native code *)
-        count bv al ; count bv al
-      end else begin (* default action will occur once *)
-        assert (nconsts < sw.sw_numconsts || nblocks < sw.sw_numblocks) ;
-        count bv al
-      end
-  in
-  count Ident.Map.empty lam;
-
-  (* Second pass: remove Lalias bindings of unused variables,
-     and substitute the bindings of variables used exactly once. *)
-
-  let subst = Hashtbl.create 83 in
-
-(* This (small)  optimisation is always legal, it may uncover some
-   tail call later on. *)
-
-  let mklet str kind v e1 e2  = match e2 with
-  | Lvar w when optimize && Ident.same v w -> e1
-  | _ -> Llet (str, kind,v,e1,e2) in
-
-
-  let rec simplif = function
-    Lvar v as l ->
-      begin try
-        Hashtbl.find subst v
-      with Not_found ->
-        l
-      end
-  | Lconst _ as l -> l
-  | Lapply{ap_func = Lfunction{kind = Curried; params; body}; ap_args = args}
-    when optimize && List.length params = List.length args ->
-      simplif (beta_reduce params body args)
-  | Lapply{ap_func = Lfunction{kind = Tupled; params; body};
-           ap_args = [Lprim(Pmakeblock _, args, _)]}
-    when optimize && List.length params = List.length args ->
-      simplif (beta_reduce params body args)
-  | Lapply ap -> Lapply {ap with ap_func = simplif ap.ap_func;
-                                 ap_args = List.map simplif ap.ap_args}
-  | Lfunction{kind; params; return=return1; body = l; attr; loc} ->
-      begin match simplif l with
-        Lfunction{kind=Curried; params=params'; return=return2; body; attr; loc}
-        when kind = Curried && optimize ->
-          (* The return type is the type of the value returned after
-             applying all the parameters to the function. The return
-             type of the merged function taking [params @ params'] as
-             parameters is the type returned after applying [params']. *)
-          let return = return2 in
-          Lfunction{kind; params = params @ params'; return; body; attr; loc}
-      | body ->
-          Lfunction{kind; params; return = return1; body; attr; loc}
-      end
-  | Llet(_str, _k, v, Lvar w, l2) when optimize ->
-      Hashtbl.add subst v (simplif (Lvar w));
-      simplif l2
-  | Llet(Strict, kind, v,
-         Lprim(Pmakeblock(0, Mutable, kind_ref) as prim, [linit], loc), lbody)
-    when optimize ->
-      let slinit = simplif linit in
-      let slbody = simplif lbody in
-      begin try
-        let kind = match kind_ref with
-          | None -> Pgenval
-          | Some [field_kind] -> field_kind
-          | Some _ -> assert false
-        in
-        mklet Variable kind v slinit (eliminate_ref v slbody)
-      with Real_reference ->
-        mklet Strict kind v (Lprim(prim, [slinit], loc)) slbody
-      end
-  | Llet(Alias, kind, v, l1, l2) ->
-      begin match count_var v with
-        0 -> simplif l2
-      | 1 when optimize -> Hashtbl.add subst v (simplif l1); simplif l2
-      | _ -> Llet(Alias, kind, v, simplif l1, simplif l2)
-      end
-  | Llet(StrictOpt, kind, v, l1, l2) ->
-      begin match count_var v with
-        0 -> simplif l2
-      | _ -> mklet StrictOpt kind v (simplif l1) (simplif l2)
-      end
-  | Llet(str, kind, v, l1, l2) -> mklet str kind v (simplif l1) (simplif l2)
-  | Lletrec(bindings, body) ->
-      Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
-  | Lprim(p, ll, loc) -> Lprim(p, List.map simplif ll, loc)
-  | Lswitch(l, sw, loc) ->
-      let new_l = simplif l
-      and new_consts =  List.map (fun (n, e) -> (n, simplif e)) sw.sw_consts
-      and new_blocks =  List.map (fun (n, e) -> (n, simplif e)) sw.sw_blocks
-      and new_fail = Misc.may_map simplif sw.sw_failaction in
-      Lswitch
-        (new_l,
-         {sw with sw_consts = new_consts ; sw_blocks = new_blocks;
-                  sw_failaction = new_fail},
-         loc)
-  | Lstringswitch (l,sw,d,loc) ->
-      Lstringswitch
-        (simplif l,List.map (fun (s,l) -> s,simplif l) sw,
-         Misc.may_map simplif d,loc)
-  | Lstaticraise (i,ls) ->
-      Lstaticraise (i, List.map simplif ls)
-  | Lstaticcatch(l1, (i,args), l2) ->
-      Lstaticcatch (simplif l1, (i,args), simplif l2)
-  | Ltrywith(l1, v, l2) -> Ltrywith(simplif l1, v, simplif l2)
-  | Lifthenelse(l1, l2, l3) -> Lifthenelse(simplif l1, simplif l2, simplif l3)
-  | Lsequence(Lifused(v, l1), l2) ->
-      if count_var v > 0
-      then Lsequence(simplif l1, simplif l2)
-      else simplif l2
-  | Lsequence(l1, l2) -> Lsequence(simplif l1, simplif l2)
-  | Lwhile(l1, l2) -> Lwhile(simplif l1, simplif l2)
-  | Lfor(v, l1, l2, dir, l3) ->
-      Lfor(v, simplif l1, simplif l2, dir, simplif l3)
-  | Lassign(v, l) -> Lassign(v, simplif l)
-  | Lsend(k, m, o, ll, loc) ->
-      Lsend(k, simplif m, simplif o, List.map simplif ll, loc)
-  | Levent(l, ev) -> Levent(simplif l, ev)
-  | Lifused(v, l) ->
-      if count_var v > 0 then simplif l else lambda_unit
-  in
-  simplif lam
-
-(* Tail call info in annotation files *)
-
-let is_tail_native_heuristic : (int -> bool) ref =
-  ref (fun _ -> true)
-
-let rec emit_tail_infos is_tail lambda =
-  let call_kind args =
-    if is_tail
-    && ((not !Clflags.native_code)
-        || (!is_tail_native_heuristic (List.length args)))
-   then Annot.Tail
-   else Annot.Stack in
-  match lambda with
-  | Lvar _ -> ()
-  | Lconst _ -> ()
-  | Lapply ap ->
-      if ap.ap_should_be_tailcall
-      && not is_tail
-      && Warnings.is_active Warnings.Expect_tailcall
-        then Location.prerr_warning ap.ap_loc Warnings.Expect_tailcall;
-      emit_tail_infos false ap.ap_func;
-      list_emit_tail_infos false ap.ap_args;
-      if !Clflags.annotations then
-        Stypes.record (Stypes.An_call (ap.ap_loc, call_kind ap.ap_args))
-  | Lfunction {body = lam} ->
-      emit_tail_infos true lam
-  | Llet (_str, _k, _, lam, body) ->
-      emit_tail_infos false lam;
-      emit_tail_infos is_tail body
-  | Lletrec (bindings, body) ->
-      List.iter (fun (_, lam) -> emit_tail_infos false lam) bindings;
-      emit_tail_infos is_tail body
-  | Lprim (Pidentity, [arg], _) ->
-      emit_tail_infos is_tail arg
-  | Lprim ((Pbytes_to_string | Pbytes_of_string), [arg], _) ->
-      emit_tail_infos is_tail arg
-  | Lprim (Psequand, [arg1; arg2], _)
-  | Lprim (Psequor, [arg1; arg2], _) ->
-      emit_tail_infos false arg1;
-      emit_tail_infos is_tail arg2
-  | Lprim (_, l, _) ->
-      list_emit_tail_infos false l
-  | Lswitch (lam, sw, _loc) ->
-      emit_tail_infos false lam;
-      list_emit_tail_infos_fun snd is_tail sw.sw_consts;
-      list_emit_tail_infos_fun snd is_tail sw.sw_blocks;
-      Misc.may  (emit_tail_infos is_tail) sw.sw_failaction
-  | Lstringswitch (lam, sw, d, _) ->
-      emit_tail_infos false lam;
-      List.iter
-        (fun (_,lam) ->  emit_tail_infos is_tail lam)
-        sw ;
-      Misc.may (emit_tail_infos is_tail) d
-  | Lstaticraise (_, l) ->
-      list_emit_tail_infos false l
-  | Lstaticcatch (body, _, handler) ->
-      emit_tail_infos is_tail body;
-      emit_tail_infos is_tail handler
-  | Ltrywith (body, _, handler) ->
-      emit_tail_infos false body;
-      emit_tail_infos is_tail handler
-  | Lifthenelse (cond, ifso, ifno) ->
-      emit_tail_infos false cond;
-      emit_tail_infos is_tail ifso;
-      emit_tail_infos is_tail ifno
-  | Lsequence (lam1, lam2) ->
-      emit_tail_infos false lam1;
-      emit_tail_infos is_tail lam2
-  | Lwhile (cond, body) ->
-      emit_tail_infos false cond;
-      emit_tail_infos false body
-  | Lfor (_, low, high, _, body) ->
-      emit_tail_infos false low;
-      emit_tail_infos false high;
-      emit_tail_infos false body
-  | Lassign (_, lam) ->
-      emit_tail_infos false lam
-  | Lsend (_, meth, obj, args, loc) ->
-      emit_tail_infos false meth;
-      emit_tail_infos false obj;
-      list_emit_tail_infos false args;
-      if !Clflags.annotations then
-        Stypes.record (Stypes.An_call (loc, call_kind (obj :: args)));
-  | Levent (lam, _) ->
-      emit_tail_infos is_tail lam
-  | Lifused (_, lam) ->
-      emit_tail_infos is_tail lam
-and list_emit_tail_infos_fun f is_tail =
-  List.iter (fun x -> emit_tail_infos is_tail (f x))
-and list_emit_tail_infos is_tail =
-  List.iter (emit_tail_infos is_tail)
-
-(* Split a function with default parameters into a wrapper and an
-   inner function.  The wrapper fills in missing optional parameters
-   with their default value and tail-calls the inner function.  The
-   wrapper can then hopefully be inlined on most call sites to avoid
-   the overhead associated with boxing an optional argument with a
-   'Some' constructor, only to deconstruct it immediately in the
-   function's body. *)
-
-let split_default_wrapper ~id:fun_id ~kind ~params ~return ~body ~attr ~loc =
-  let rec aux map = function
-    | Llet(Strict, k, id, (Lifthenelse(Lvar optparam, _, _) as def), rest) when
-        Ident.name optparam = "*opt*" && List.mem_assoc optparam params
-          && not (List.mem_assoc optparam map)
-      ->
-        let wrapper_body, inner = aux ((optparam, id) :: map) rest in
-        Llet(Strict, k, id, def, wrapper_body), inner
-    | _ when map = [] -> raise Exit
-    | body ->
-        (* Check that those *opt* identifiers don't appear in the remaining
-           body. This should not appear, but let's be on the safe side. *)
-        let fv = Lambda.free_variables body in
-        List.iter (fun (id, _) -> if Ident.Set.mem id fv then raise Exit) map;
-
-        let inner_id = Ident.create_local (Ident.name fun_id ^ "_inner") in
-        let map_param p = try List.assoc p map with Not_found -> p in
-        let args = List.map (fun (p, _) -> Lvar (map_param p)) params in
-        let wrapper_body =
-          Lapply {
-            ap_func = Lvar inner_id;
-            ap_args = args;
-            ap_loc = Location.none;
-            ap_should_be_tailcall = false;
-            ap_inlined = Default_inline;
-            ap_specialised = Default_specialise;
-          }
-        in
-        let inner_params = List.map map_param (List.map fst params) in
-        let new_ids = List.map Ident.rename inner_params in
-        let subst =
-          List.fold_left2 (fun s id new_id ->
-            Ident.Map.add id new_id s
-          ) Ident.Map.empty inner_params new_ids
-        in
-        let body = Lambda.rename subst body in
-        let inner_fun =
-          Lfunction { kind = Curried;
-            params = List.map (fun id -> id, Pgenval) new_ids;
-            return; body; attr; loc; }
-        in
-        (wrapper_body, (inner_id, inner_fun))
-  in
-  try
-    let body, inner = aux [] body in
-    let attr = default_stub_attribute in
-    [(fun_id, Lfunction{kind; params; return; body; attr; loc}); inner]
-  with Exit ->
-    [(fun_id, Lfunction{kind; params; return; body; attr; loc})]
-
-(* Simplify local let-bound functions: if all occurrences are
-   fully-applied function calls in the same "tail scope", replace the
-   function by a staticcatch handler (on that scope).
-
-   This handles as a special case functions used exactly once (in any
-   scope) for a full application.
-*)
-
-type slot =
-  {
-    nargs: int;
-    mutable scope: lambda option;
-  }
-
-module LamTbl = Hashtbl.Make(struct
-    type t = lambda
-    let equal = (==)
-    let hash = Hashtbl.hash
-  end)
-
-let simplify_local_functions lam =
-  let slots = Hashtbl.create 16 in
-  let static_id = Hashtbl.create 16 in (* function id -> static id *)
-  let static = LamTbl.create 16 in (* scope -> static function on that scope *)
-  (* We keep track of the current "tail scope", identified
-     by the outermost lambda for which the the current lambda
-     is in tail position. *)
-  let current_scope = ref lam in
-  let check_static lf =
-    if lf.attr.local = Always_local then
-      Location.prerr_warning lf.loc
-        (Warnings.Inlining_impossible
-           "This function cannot be compiled into a static continuation")
-  in
-  let enabled = function
-    | {local = Always_local; _}
-    | {local = Default_local; inline = (Never_inline | Default_inline); _}
-      -> true
-    | {local = Default_local; inline = (Always_inline | Unroll _); _}
-    | {local = Never_local; _}
-      -> false
-  in
-  let rec tail = function
-    | Llet (_str, _kind, id, Lfunction lf, cont) when enabled lf.attr ->
-        let r = {nargs=List.length lf.params; scope=None} in
-        Hashtbl.add slots id r;
-        tail cont;
-        begin match Hashtbl.find_opt slots id with
-        | Some {scope = Some scope; _} ->
-            let st = next_raise_count () in
-            let sc =
-              (* Do not move higher than current lambda *)
-              if scope == !current_scope then cont
-              else scope
-            in
-            Hashtbl.add static_id id st;
-            LamTbl.add static sc (st, lf);
-            (* The body of the function will become an handler
-               in that "scope". *)
-            with_scope ~scope lf.body
-        | _ ->
-            check_static lf;
-            (* note: if scope = None, the function is unused *)
-            non_tail lf.body
-        end
-    | Lapply {ap_func = Lvar id; ap_args; _} ->
-        begin match Hashtbl.find_opt slots id with
-        | Some {nargs; _} when nargs <> List.length ap_args ->
-            (* Wrong arity *)
-            Hashtbl.remove slots id
-        | Some {scope = Some scope; _} when scope != !current_scope ->
-            (* Different "tail scope" *)
-            Hashtbl.remove slots id
-        | Some ({scope = None; _} as slot) ->
-            (* First use of the function: remember the current tail scope *)
-            slot.scope <- Some !current_scope
-        | _ ->
-            ()
-        end;
-        List.iter non_tail ap_args
-    | Lvar id ->
-        Hashtbl.remove slots id
-    | Lfunction lf as lam ->
-        check_static lf;
-        Lambda.shallow_iter ~tail ~non_tail lam
-    | lam ->
-        Lambda.shallow_iter ~tail ~non_tail lam
-  and non_tail lam =
-    with_scope ~scope:lam lam
-  and with_scope ~scope lam =
-    let old_scope = !current_scope in
-    current_scope := scope;
-    tail lam;
-    current_scope := old_scope
-  in
-  tail lam;
-  let rec rewrite lam0 =
-    let lam =
-      match lam0 with
-      | Llet (_, _, id, _, cont) when Hashtbl.mem static_id id ->
-          rewrite cont
-      | Lapply {ap_func = Lvar id; ap_args; _} when Hashtbl.mem static_id id ->
-          Lstaticraise (Hashtbl.find static_id id, List.map rewrite ap_args)
-      | lam ->
-          Lambda.shallow_map rewrite lam
-    in
-    List.fold_right
-      (fun (st, lf) lam ->
-         Lstaticcatch (lam, (st, lf.params), rewrite lf.body)
-      )
-      (LamTbl.find_all static lam0)
-      lam
-  in
-  if LamTbl.length static = 0 then
-    lam
-  else
-    rewrite lam
-
-(* The entry point:
-   simplification + emission of tailcall annotations, if needed. *)
-
-let simplify_lambda lam =
-  let lam =
-    lam
-    |> (if !Clflags.native_code || not !Clflags.debug
-        then simplify_local_functions else Fun.id
-       )
-    |> simplify_exits
-    |> simplify_lets
-  in
-  if !Clflags.annotations || Warnings.is_active Warnings.Expect_tailcall
-    then emit_tail_infos true lam;
-  lam
diff --git a/bytecomp/simplif.mli b/bytecomp/simplif.mli
deleted file mode 100644
index d5ca210e5a..0000000000
--- a/bytecomp/simplif.mli
+++ /dev/null
@@ -1,44 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 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.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(** Lambda simplification.
-
-  {b Warning:} this module is unstable and part of
-  {{!Compiler_libs}compiler-libs}.
-
-*)
-
-(* Elimination of useless Llet(Alias) bindings.
-   Transformation of let-bound references into variables.
-   Simplification over staticraise/staticcatch constructs.
-   Generation of tail-call annotations if -annot is set. *)
-
-open Lambda
-
-val simplify_lambda: lambda -> lambda
-
-val split_default_wrapper
-   : id:Ident.t
-  -> kind:function_kind
-  -> params:(Ident.t * Lambda.value_kind) list
-  -> return:Lambda.value_kind
-  -> body:lambda
-  -> attr:function_attribute
-  -> loc:Location.t
-  -> (Ident.t * lambda) list
-
-(* To be filled by asmcomp/selectgen.ml *)
-val is_tail_native_heuristic: (int -> bool) ref
-                          (* # arguments -> can tailcall *)
diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml
deleted file mode 100644
index 89bfe83a07..0000000000
--- a/bytecomp/switch.ml
+++ /dev/null
@@ -1,877 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Luc Maranget, projet Moscova, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2000 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 'a shared = Shared of 'a | Single of 'a
-
-type ('a, 'ctx) t_store =
-  {act_get : unit -> 'a array ;
-   act_get_shared : unit -> 'a shared array ;
-   act_store : 'ctx -> 'a -> int ;
-   act_store_shared : 'ctx -> 'a -> int ; }
-
-exception Not_simple
-
-module type Stored = sig
-  type t
-  type key
-  val compare_key : key -> key -> int
-  val make_key : t -> key option
-end
-
-module type CtxStored = sig
-  include Stored
-  type context
-  val make_key : context -> t -> key option
-end
-
-module CtxStore(A:CtxStored) = struct
-  module AMap =
-    Map.Make(struct type t = A.key let compare = A.compare_key end)
-
-  type intern =
-    { mutable map : (bool * int)  AMap.t ;
-      mutable next : int ;
-      mutable acts : (bool * A.t) list; }
-
-  let mk_store () =
-    let st =
-      { map = AMap.empty ;
-        next = 0 ;
-        acts = [] ; } in
-
-    let add mustshare act =
-      let i = st.next in
-      st.acts <- (mustshare,act) :: st.acts ;
-      st.next <- i+1 ;
-      i in
-
-    let store mustshare ctx act = match A.make_key ctx act with
-      | Some key ->
-          begin try
-            let (shared,i) = AMap.find key st.map in
-            if not shared then st.map <- AMap.add key (true,i) st.map ;
-            i
-          with Not_found ->
-            let i = add mustshare act in
-            st.map <- AMap.add key (mustshare,i) st.map ;
-            i
-          end
-      | None ->
-          add mustshare act
-
-    and get () = Array.of_list (List.rev_map (fun (_,act) -> act) st.acts)
-
-    and get_shared () =
-      let acts =
-        Array.of_list
-          (List.rev_map
-             (fun (shared,act) ->
-                if shared then Shared act else Single act)
-             st.acts) in
-      AMap.iter
-        (fun _ (shared,i) ->
-           if shared then match acts.(i) with
-             | Single act -> acts.(i) <- Shared act
-             | Shared _ -> ())
-        st.map ;
-      acts in
-    {act_store = store false ; act_store_shared = store true ;
-     act_get = get; act_get_shared = get_shared; }
-end
-
-module Store(A:Stored) = struct
-  module Me =
-    CtxStore
-      (struct
-        include A
-        type context = unit
-        let make_key () = A.make_key
-      end)
-
-  let mk_store = Me.mk_store
-end
-
-
-
-module type S =
-sig
-  type primitive
-  val eqint : primitive
-  val neint : primitive
-  val leint : primitive
-  val ltint : primitive
-  val geint : primitive
-  val gtint : primitive
-  type act
-
-  val bind : act -> (act -> act) -> act
-  val make_const : int -> act
-  val make_offset : act -> int -> act
-  val make_prim : primitive -> act list -> act
-  val make_isout : act -> act -> act
-  val make_isin : act -> act -> act
-  val make_if : act -> act -> act -> act
-  val make_switch : Location.t -> act -> int array -> act array -> act
-  val make_catch : act -> int * (act -> act)
-  val make_exit : int -> act
-end
-
-(* The module will ``produce good code for the case statement'' *)
-(*
-  Adaptation of
-   R.L. Berstein
-   ``Producing good code for the case statement''
-   Software Practice and Experience, 15(10) (1985)
- and
-   D.L. Spuler
-    ``Two-Way Comparison Search Trees, a Generalisation of Binary Search Trees
-      and Split Trees''
-    ``Compiler Code Generation for Multiway Branch Statement as
-      a Static Search Problem''
-   Technical Reports, James Cook University
-*)
-(*
-  Main adaptation is considering interval tests
- (implemented as one addition + one unsigned test and branch)
-  which leads to exhaustive search for finding the optimal
-  test sequence in small cases and heuristics otherwise.
-*)
-module Make (Arg : S) =
-struct
-
-  type 'a inter =
-    {cases : (int * int * int) array ;
-     actions : 'a array}
-
-  type 'a t_ctx =  {off : int ; arg : 'a}
-
-  let cut = ref 8
-  and more_cut = ref 16
-
-(*
-let pint chan i =
-  if i = min_int then Printf.fprintf chan "-oo"
-  else if i=max_int then Printf.fprintf chan "oo"
-  else Printf.fprintf chan "%d" i
-
-let pcases chan cases =
-  for i =0 to Array.length cases-1 do
-    let l,h,act = cases.(i) in
-    if l=h then
-      Printf.fprintf chan "%d:%d " l act
-    else
-      Printf.fprintf chan "%a..%a:%d " pint l pint h act
-  done
-
-let prerr_inter i = Printf.fprintf stderr
-        "cases=%a" pcases i.cases
-*)
-
-  let get_act cases i =
-    let _,_,r = cases.(i) in
-    r
-  and get_low cases i =
-    let r,_,_ = cases.(i) in
-    r
-
-  type ctests = {
-    mutable n : int ;
-    mutable ni : int ;
-  }
-
-  let too_much = {n=max_int ; ni=max_int}
-
-(*
-let ptests chan {n=n ; ni=ni} =
-  Printf.fprintf chan "{n=%d ; ni=%d}" n ni
-
-let pta chan t =
-  for i =0 to Array.length t-1 do
-    Printf.fprintf chan "%d: %a\n" i ptests t.(i)
-  done
-*)
-
-  let less_tests c1 c2 =
-    if c1.n < c2.n then
-      true
-    else if c1.n = c2.n then begin
-      if c1.ni < c2.ni then
-        true
-      else
-        false
-    end else
-      false
-
-  and eq_tests c1 c2 = c1.n = c2.n && c1.ni=c2.ni
-
-  let less2tests (c1,d1) (c2,d2) =
-    if eq_tests c1 c2 then
-      less_tests d1 d2
-    else
-      less_tests c1 c2
-
-  let add_test t1 t2 =
-    t1.n <- t1.n + t2.n ;
-    t1.ni <- t1.ni + t2.ni ;
-
-  type t_ret = Inter of int * int  | Sep of int | No
-
-(*
-let pret chan = function
-  | Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j
-  | Sep i -> Printf.fprintf chan "Sep %d" i
-  | No -> Printf.fprintf chan "No"
-*)
-
-  let coupe cases i =
-    let l,_,_ = cases.(i) in
-    l,
-    Array.sub cases 0 i,
-    Array.sub cases i (Array.length cases-i)
-
-
-  let case_append c1 c2 =
-    let len1 = Array.length c1
-    and len2 = Array.length c2 in
-    match len1,len2 with
-    | 0,_ -> c2
-    | _,0 -> c1
-    | _,_ ->
-        let l1,h1,act1 = c1.(Array.length c1-1)
-        and l2,h2,act2 = c2.(0) in
-        if act1 = act2 then
-          let r = Array.make (len1+len2-1) c1.(0) in
-          for i = 0 to len1-2 do
-            r.(i) <- c1.(i)
-          done ;
-
-          let l =
-            if len1-2 >= 0 then begin
-              let _,h,_ = r.(len1-2) in
-              if h+1 < l1 then
-                h+1
-              else
-                l1
-            end else
-              l1
-          and h =
-            if 1 < len2-1 then begin
-              let l,_,_ = c2.(1) in
-              if h2+1 < l then
-                l-1
-              else
-                h2
-            end else
-              h2 in
-          r.(len1-1) <- (l,h,act1) ;
-          for i=1 to len2-1  do
-            r.(len1-1+i) <- c2.(i)
-          done ;
-          r
-        else if h1 > l1 then
-          let r = Array.make (len1+len2) c1.(0) in
-          for i = 0 to len1-2 do
-            r.(i) <- c1.(i)
-          done ;
-          r.(len1-1) <- (l1,l2-1,act1) ;
-          for i=0 to len2-1  do
-            r.(len1+i) <- c2.(i)
-          done ;
-          r
-        else if h2 > l2 then
-          let r = Array.make (len1+len2) c1.(0) in
-          for i = 0 to len1-1 do
-            r.(i) <- c1.(i)
-          done ;
-          r.(len1) <- (h1+1,h2,act2) ;
-          for i=1 to len2-1  do
-            r.(len1+i) <- c2.(i)
-          done ;
-          r
-        else
-          Array.append c1 c2
-
-
-  let coupe_inter i j cases =
-    let lcases = Array.length cases in
-    let low,_,_ = cases.(i)
-    and _,high,_ = cases.(j) in
-    low,high,
-    Array.sub cases i (j-i+1),
-    case_append (Array.sub cases 0 i) (Array.sub cases (j+1) (lcases-(j+1)))
-
-  type kind = Kvalue of int | Kinter of int | Kempty
-
-(*
-let pkind chan = function
-  | Kvalue i ->Printf.fprintf chan "V%d" i
-  | Kinter i -> Printf.fprintf chan "I%d" i
-  | Kempty -> Printf.fprintf chan "E"
-
-let rec pkey chan  = function
-  | [] -> ()
-  | [k] -> pkind chan k
-  | k::rem ->
-      Printf.fprintf chan "%a %a" pkey rem pkind k
-*)
-
-  let t = Hashtbl.create 17
-
-  let make_key  cases =
-    let seen = ref []
-    and count = ref 0 in
-    let rec got_it act = function
-      | [] ->
-          seen := (act,!count):: !seen ;
-          let r = !count in
-          incr count ;
-          r
-      | (act0,index) :: rem ->
-          if act0 = act then
-            index
-          else
-            got_it act rem in
-
-    let make_one l h act =
-      if l=h then
-        Kvalue (got_it act !seen)
-      else
-        Kinter (got_it act !seen) in
-
-    let rec make_rec i pl =
-      if i < 0 then
-        []
-      else
-        let l,h,act = cases.(i) in
-        if pl = h+1 then
-          make_one l h act::make_rec (i-1) l
-        else
-          Kempty::make_one l h act::make_rec (i-1) l in
-
-    let l,h,act = cases.(Array.length cases-1) in
-    make_one l h act::make_rec (Array.length cases-2) l
-
-
-  let same_act t =
-    let len = Array.length t in
-    let a = get_act t (len-1) in
-    let rec do_rec i =
-      if i < 0 then true
-      else
-        let b = get_act t i in
-        b=a && do_rec (i-1) in
-    do_rec (len-2)
-
-
-(*
-  Interval test x in [l,h] works by checking x-l in [0,h-l]
-   * This may be false for arithmetic modulo 2^31
-   * Subtracting l may change the relative ordering of values
-     and invalid the invariant that matched values are given in
-     increasing order
-
-   To avoid this, interval check is allowed only when the
-   integers indeed present in the whole case interval are
-   in [-2^16 ; 2^16]
-
-   This condition is checked by zyva
-*)
-
-  let inter_limit = 1 lsl 16
-
-  let ok_inter = ref false
-
-  let rec opt_count top cases =
-    let key = make_key cases in
-    try
-      Hashtbl.find t key
-    with
-    | Not_found ->
-        let r =
-          let lcases = Array.length cases in
-          match lcases with
-          | 0 -> assert false
-          | _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0})
-          | _ ->
-              if lcases < !cut then
-                enum top cases
-              else if lcases < !more_cut then
-                heuristic cases
-              else
-                divide cases in
-        Hashtbl.add t key r ;
-        r
-
-  and divide cases =
-    let lcases = Array.length cases in
-    let m = lcases/2 in
-    let _,left,right = coupe cases m in
-    let ci = {n=1 ; ni=0}
-    and cm = {n=1 ; ni=0}
-    and _,(cml,cleft) = opt_count false left
-    and _,(cmr,cright) = opt_count false right in
-    add_test ci cleft ;
-    add_test ci cright ;
-    if less_tests cml cmr then
-      add_test cm cmr
-    else
-      add_test cm cml ;
-    Sep m,(cm, ci)
-
-  and heuristic cases =
-    let lcases = Array.length cases in
-
-    let sep,csep = divide cases
-
-    and inter,cinter =
-      if !ok_inter then begin
-        let _,_,act0 = cases.(0)
-        and _,_,act1 = cases.(lcases-1) in
-        if act0 = act1 then begin
-          let low, high, inside, outside = coupe_inter 1 (lcases-2) cases in
-          let _,(cmi,cinside) = opt_count false inside
-          and _,(cmo,coutside) = opt_count false outside
-          and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
-          and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
-          add_test cij cinside ;
-          add_test cij coutside ;
-          if less_tests cmi cmo then
-            add_test cmij cmo
-          else
-            add_test cmij cmi ;
-          Inter (1,lcases-2),(cmij,cij)
-        end else
-          Inter (-1,-1),(too_much, too_much)
-      end else
-        Inter (-1,-1),(too_much, too_much) in
-    if less2tests csep cinter then
-      sep,csep
-    else
-      inter,cinter
-
-
-  and enum top cases =
-    let lcases = Array.length cases in
-    let lim, with_sep =
-      let best = ref (-1) and best_cost = ref (too_much,too_much) in
-
-      for i = 1 to lcases-(1) do
-        let _,left,right = coupe cases i in
-        let ci = {n=1 ; ni=0}
-        and cm = {n=1 ; ni=0}
-        and _,(cml,cleft) = opt_count false left
-        and _,(cmr,cright) = opt_count false right in
-        add_test ci cleft ;
-        add_test ci cright ;
-        if less_tests cml cmr then
-          add_test cm cmr
-        else
-          add_test cm cml ;
-
-        if
-          less2tests (cm,ci) !best_cost
-        then begin
-          if top then
-            Printf.fprintf stderr "Get it: %d\n" i ;
-          best := i ;
-          best_cost := (cm,ci)
-        end
-      done ;
-      !best, !best_cost in
-
-    let ilow, ihigh, with_inter =
-      if not !ok_inter then
-        let rlow = ref (-1) and rhigh = ref (-1)
-        and best_cost= ref (too_much,too_much) in
-        for i=1 to lcases-2 do
-          let low, high, inside, outside = coupe_inter i i cases in
-          if low=high then begin
-            let _,(cmi,cinside) = opt_count false inside
-            and _,(cmo,coutside) = opt_count false outside
-            and cmij = {n=1 ; ni=0}
-            and cij = {n=1 ; ni=0} in
-            add_test cij cinside ;
-            add_test cij coutside ;
-            if less_tests cmi cmo then
-              add_test cmij cmo
-            else
-              add_test cmij cmi ;
-            if less2tests (cmij,cij) !best_cost then begin
-              rlow := i ;
-              rhigh := i ;
-              best_cost := (cmij,cij)
-            end
-          end
-        done ;
-        !rlow, !rhigh, !best_cost
-      else
-        let rlow = ref (-1) and rhigh = ref (-1)
-        and best_cost= ref (too_much,too_much) in
-        for i=1 to lcases-2 do
-          for j=i to lcases-2 do
-            let low, high, inside, outside = coupe_inter i j cases in
-            let _,(cmi,cinside) = opt_count false inside
-            and _,(cmo,coutside) = opt_count false outside
-            and cmij = {n=1 ; ni=(if low=high then 0 else 1)}
-            and cij = {n=1 ; ni=(if low=high then 0 else 1)} in
-            add_test cij cinside ;
-            add_test cij coutside ;
-            if less_tests cmi cmo then
-              add_test cmij cmo
-            else
-              add_test cmij cmi ;
-            if less2tests (cmij,cij) !best_cost then begin
-              rlow := i ;
-              rhigh := j ;
-              best_cost := (cmij,cij)
-            end
-          done
-        done ;
-        !rlow, !rhigh, !best_cost in
-    let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in
-    if less2tests with_sep !rc then begin
-      r := Sep lim ; rc := with_sep
-    end ;
-    !r, !rc
-
-  let make_if_test test arg i ifso ifnot =
-    Arg.make_if
-      (Arg.make_prim test [arg ; Arg.make_const i])
-      ifso ifnot
-
-  let make_if_lt arg i  ifso ifnot = match i with
-    | 1 ->
-        make_if_test Arg.leint arg 0 ifso ifnot
-    | _ ->
-        make_if_test Arg.ltint arg i ifso ifnot
-
-  and make_if_ge arg i  ifso ifnot = match i with
-    | 1 ->
-        make_if_test Arg.gtint arg 0 ifso ifnot
-    | _ ->
-        make_if_test Arg.geint arg i ifso ifnot
-
-  and make_if_eq  arg i ifso ifnot =
-    make_if_test Arg.eqint arg i ifso ifnot
-
-  and make_if_ne  arg i ifso ifnot =
-    make_if_test Arg.neint arg i ifso ifnot
-
-  let do_make_if_out h arg ifso ifno =
-    Arg.make_if (Arg.make_isout h arg) ifso ifno
-
-  let make_if_out ctx l d mk_ifso mk_ifno = match l with
-    | 0 ->
-        do_make_if_out
-          (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx)
-    | _ ->
-        Arg.bind
-          (Arg.make_offset ctx.arg (-l))
-          (fun arg ->
-             let ctx = {off= (-l+ctx.off) ; arg=arg} in
-             do_make_if_out
-               (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx))
-
-  let do_make_if_in h arg ifso ifno =
-    Arg.make_if (Arg.make_isin h arg) ifso ifno
-
-  let make_if_in ctx l d mk_ifso mk_ifno = match l with
-    | 0 ->
-        do_make_if_in
-          (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx)
-    | _ ->
-        Arg.bind
-          (Arg.make_offset ctx.arg (-l))
-          (fun arg ->
-             let ctx = {off= (-l+ctx.off) ; arg=arg} in
-             do_make_if_in
-               (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx))
-
-  let rec c_test ctx ({cases=cases ; actions=actions} as s) =
-    let lcases = Array.length cases in
-    assert(lcases > 0) ;
-    if lcases = 1 then
-      actions.(get_act cases 0) ctx
-
-    else begin
-
-      let w,_c = opt_count false cases in
-(*
-  Printf.fprintf stderr
-  "off=%d tactic=%a for %a\n"
-  ctx.off pret w pcases cases ;
-  *)
-      match w with
-      | No -> actions.(get_act cases 0) ctx
-      | Inter (i,j) ->
-          let low,high,inside, outside = coupe_inter i j cases in
-          let _,(cinside,_) = opt_count false inside
-          and _,(coutside,_) = opt_count false outside in
-          (* Costs are retrieved to put the code with more remaining tests
-             in the privileged (positive) branch of ``if'' *)
-          if low=high then begin
-            if less_tests coutside cinside then
-              make_if_eq
-                ctx.arg
-                (low+ctx.off)
-                (c_test ctx {s with cases=inside})
-                (c_test ctx {s with cases=outside})
-            else
-              make_if_ne
-                ctx.arg
-                (low+ctx.off)
-                (c_test ctx {s with cases=outside})
-                (c_test ctx {s with cases=inside})
-          end else begin
-            if less_tests coutside cinside then
-              make_if_in
-                ctx
-                (low+ctx.off)
-                (high-low)
-                (fun ctx -> c_test ctx {s with cases=inside})
-                (fun ctx -> c_test ctx {s with cases=outside})
-            else
-              make_if_out
-                ctx
-                (low+ctx.off)
-                (high-low)
-                (fun ctx -> c_test ctx {s with cases=outside})
-                (fun ctx -> c_test ctx {s with cases=inside})
-          end
-      | Sep i ->
-          let lim,left,right = coupe cases i in
-          let _,(cleft,_) = opt_count false left
-          and _,(cright,_) = opt_count false right in
-          let left = {s with cases=left}
-          and right = {s with cases=right} in
-
-          if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then
-            make_if_ne
-              ctx.arg 0
-              (c_test ctx right) (c_test ctx left)
-          else if less_tests cright cleft then
-            make_if_lt
-              ctx.arg (lim+ctx.off)
-              (c_test ctx left) (c_test ctx right)
-          else
-            make_if_ge
-              ctx.arg (lim+ctx.off)
-              (c_test ctx right) (c_test ctx left)
-
-    end
-
-
-  (* Minimal density of switches *)
-  let theta = ref 0.33333
-
-  (* Minimal number of tests to make a switch *)
-  let switch_min = ref 3
-
-  (* Particular case 0, 1, 2 *)
-  let particular_case cases i j =
-    j-i = 2 &&
-    (let l1,_h1,act1 = cases.(i)
-     and  l2,_h2,_act2 = cases.(i+1)
-     and  l3,h3,act3 = cases.(i+2) in
-     l1+1=l2 && l2+1=l3 && l3=h3 &&
-     act1 <> act3)
-
-  let approx_count cases i j =
-    let l = j-i+1 in
-    if l < !cut then
-      let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in
-      ntests
-    else
-      l-1
-
-  (* Sends back a boolean that says whether is switch is worth or not *)
-
-  let dense {cases} i j =
-    if i=j then true
-    else
-      let l,_,_ = cases.(i)
-      and _,h,_ = cases.(j) in
-      let ntests =  approx_count cases i j in
-(*
-  (ntests+1) >= theta * (h-l+1)
-*)
-      particular_case cases i j ||
-      (ntests >= !switch_min &&
-       float_of_int ntests +. 1.0 >=
-       !theta *. (float_of_int h -. float_of_int l +. 1.0))
-
-  (* Compute clusters by dynamic programming
-     Adaptation of the correction to Bernstein
-     ``Correction to `Producing Good Code for the Case Statement' ''
-     S.K. Kannan and T.A. Proebsting
-     Software Practice and Experience Vol. 24(2) 233 (Feb 1994)
-  *)
-
-  let comp_clusters s =
-    let len = Array.length s.cases in
-    let min_clusters = Array.make len max_int
-    and k = Array.make len 0 in
-    let get_min i = if i < 0 then 0 else min_clusters.(i) in
-
-    for i = 0 to len-1 do
-      for j = 0 to i do
-        if
-          dense s j i &&
-          get_min (j-1) + 1 < min_clusters.(i)
-        then begin
-          k.(i) <- j ;
-          min_clusters.(i) <- get_min (j-1) + 1
-        end
-      done ;
-    done ;
-    min_clusters.(len-1),k
-
-  (* Assume j > i *)
-  let make_switch loc {cases=cases ; actions=actions} i j =
-    let ll,_,_ = cases.(i)
-    and _,hh,_ = cases.(j) in
-    let tbl = Array.make (hh-ll+1) 0
-    and t = Hashtbl.create 17
-    and index = ref 0 in
-    let get_index act =
-      try
-        Hashtbl.find t act
-      with
-      | Not_found ->
-          let i = !index in
-          incr index ;
-          Hashtbl.add t act i ;
-          i in
-
-    for k=i to j do
-      let l,h,act = cases.(k) in
-      let index = get_index act in
-      for kk=l-ll to h-ll do
-        tbl.(kk) <- index
-      done
-    done ;
-    let acts = Array.make !index actions.(0) in
-    Hashtbl.iter
-      (fun act i -> acts.(i) <- actions.(act))
-      t ;
-    (fun ctx ->
-       match -ll-ctx.off with
-       | 0 -> Arg.make_switch loc ctx.arg tbl acts
-       | _ ->
-           Arg.bind
-             (Arg.make_offset ctx.arg (-ll-ctx.off))
-             (fun arg -> Arg.make_switch loc arg tbl acts))
-
-
-  let make_clusters loc ({cases=cases ; actions=actions} as s) n_clusters k =
-    let len = Array.length cases in
-    let r = Array.make n_clusters (0,0,0)
-    and t = Hashtbl.create 17
-    and index = ref 0
-    and bidon = ref (Array.length actions) in
-    let get_index act =
-      try
-        let i,_ = Hashtbl.find t act in
-        i
-      with
-      | Not_found ->
-          let i = !index in
-          incr index ;
-          Hashtbl.add
-            t act
-            (i,(fun _ -> actions.(act))) ;
-          i
-    and add_index act =
-      let i = !index in
-      incr index ;
-      incr bidon ;
-      Hashtbl.add t !bidon (i,act) ;
-      i in
-
-    let rec zyva j ir =
-      let i = k.(j) in
-      begin if i=j then
-          let l,h,act = cases.(i) in
-          r.(ir) <- (l,h,get_index act)
-        else (* assert i < j *)
-          let l,_,_ = cases.(i)
-          and _,h,_ = cases.(j) in
-          r.(ir) <- (l,h,add_index (make_switch loc s i j))
-      end ;
-      if i > 0 then zyva (i-1) (ir-1) in
-
-    zyva (len-1) (n_clusters-1) ;
-    let acts = Array.make !index (fun _ -> assert false) in
-    Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ;
-    {cases = r ; actions = acts}
-  ;;
-
-
-  let do_zyva loc (low,high) arg cases actions =
-    let old_ok = !ok_inter in
-    ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ;
-    if !ok_inter <> old_ok then Hashtbl.clear t ;
-
-    let s = {cases=cases ; actions=actions} in
-
-(*
-  Printf.eprintf "ZYVA: %B [low=%i,high=%i]\n" !ok_inter low high ;
-  pcases stderr cases ;
-  prerr_endline "" ;
-*)
-    let n_clusters,k = comp_clusters s in
-    let clusters = make_clusters loc s n_clusters k in
-    c_test {arg=arg ; off=0} clusters
-
-  let abstract_shared actions =
-    let handlers = ref (fun x -> x) in
-    let actions =
-      Array.map
-        (fun act -> match  act with
-           | Single act -> act
-           | Shared act ->
-               let i,h = Arg.make_catch act in
-               let oh = !handlers in
-               handlers := (fun act -> h (oh act)) ;
-               Arg.make_exit i)
-        actions in
-    !handlers,actions
-
-  let zyva loc lh arg cases actions =
-    assert (Array.length cases > 0) ;
-    let actions = actions.act_get_shared () in
-    let hs,actions = abstract_shared actions in
-    hs (do_zyva loc lh arg cases actions)
-
-  and test_sequence arg cases actions =
-    assert (Array.length cases > 0) ;
-    let actions = actions.act_get_shared () in
-    let hs,actions = abstract_shared actions in
-    let old_ok = !ok_inter in
-    ok_inter := false ;
-    if !ok_inter <> old_ok then Hashtbl.clear t ;
-    let s =
-      {cases=cases ;
-       actions=Array.map (fun act -> (fun _ -> act)) actions} in
-(*
-  Printf.eprintf "SEQUENCE: %B\n" !ok_inter ;
-  pcases stderr cases ;
-  prerr_endline "" ;
-*)
-    hs (c_test {arg=arg ; off=0} s)
-  ;;
-
-end
diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli
deleted file mode 100644
index b4058c1784..0000000000
--- a/bytecomp/switch.mli
+++ /dev/null
@@ -1,129 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*             Luc Maranget, projet Moscova, INRIA Rocquencourt           *)
-(*                                                                        *)
-(*   Copyright 2000 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.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(*
-  This module transforms generic switches in combinations
-  of if tests and switches.
-*)
-
-(* For detecting action sharing, object style *)
-
-(* Store for actions in object style:
-  act_store : store an action, returns index in table
-              In case an action with equal key exists, returns index
-              of the stored action. Otherwise add entry in table.
-  act_store_shared : This stored action will always be shared.
-  act_get   : retrieve table
-  act_get_shared : retrieve table, with sharing explicit
-*)
-
-type 'a shared = Shared of 'a | Single of 'a
-
-type ('a, 'ctx) t_store =
-    {act_get : unit -> 'a array ;
-     act_get_shared : unit -> 'a shared array ;
-     act_store : 'ctx -> 'a -> int ;
-     act_store_shared : 'ctx -> 'a -> int ; }
-
-exception Not_simple
-
-module type Stored = sig
-  type t
-  type key
-  val compare_key : key -> key -> int
-  val make_key : t -> key option
-end
-
-module type CtxStored = sig
-  include Stored
-  type context
-  val make_key : context -> t -> key option
-end
-
-module CtxStore(A:CtxStored) :
-    sig
-      val mk_store : unit -> (A.t, A.context) t_store
-    end
-
-module Store(A:Stored) :
-    sig
-      val mk_store : unit -> (A.t, unit) t_store
-    end
-
-(* Arguments to the Make functor *)
-module type S =
-  sig
-    (* type of basic tests *)
-    type primitive
-    (* basic tests themselves *)
-    val eqint : primitive
-    val neint : primitive
-    val leint : primitive
-    val ltint : primitive
-    val geint : primitive
-    val gtint : primitive
-    (* type of actions *)
-    type act
-
-    (* Various constructors, for making a binder,
-        adding one integer, etc. *)
-    val bind : act -> (act -> act) -> act
-    val make_const : int -> act
-    val make_offset : act -> int -> act
-    val make_prim : primitive -> act list -> act
-    val make_isout : act -> act -> act
-    val make_isin : act -> act -> act
-    val make_if : act -> act -> act -> act
-   (* construct an actual switch :
-      make_switch arg cases acts
-      NB:  cases is in the value form *)
-    val make_switch :
-        Location.t -> act -> int array -> act array -> act
-   (* Build last minute sharing of action stuff *)
-   val make_catch : act -> int * (act -> act)
-   val make_exit : int -> act
-
-  end
-
-
-(*
-  Make.zyva arg low high cases actions where
-    - arg is the argument of the switch.
-    - low, high are the interval limits.
-    - cases is a list of sub-interval and action indices
-    - actions is an array of actions.
-
-  All these arguments specify a switch construct and zyva
-  returns an action that performs the switch.
-*)
-module Make :
-  functor (Arg : S) ->
-    sig
-(* Standard entry point, sharing is tracked *)
-      val zyva :
-          Location.t ->
-          (int * int) ->
-           Arg.act ->
-           (int * int * int) array ->
-           (Arg.act, _) t_store ->
-           Arg.act
-
-(* Output test sequence, sharing tracked *)
-     val test_sequence :
-           Arg.act ->
-           (int * int * int) array ->
-           (Arg.act, _) t_store ->
-           Arg.act
-    end
diff --git a/bytecomp/translattribute.ml b/bytecomp/translattribute.ml
deleted file mode 100644
index 1520a3b41f..0000000000
--- a/bytecomp/translattribute.ml
+++ /dev/null
@@ -1,332 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*                      Pierre Chambart, OCamlPro                         *)
-(*                                                                        *)
-(*   Copyright 2015 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 Typedtree
-open Lambda
-open Location
-
-let is_inline_attribute = function
-  | {txt=("inline"|"ocaml.inline")} -> true
-  | _ -> false
-
-let is_inlined_attribute = function
-  | {txt=("inlined"|"ocaml.inlined")} -> true
-  | {txt=("unrolled"|"ocaml.unrolled")} when Config.flambda -> true
-  | _ -> false
-
-let is_specialise_attribute = function
-  | {txt=("specialise"|"ocaml.specialise")} when Config.flambda -> true
-  | _ -> false
-
-let is_specialised_attribute = function
-  | {txt=("specialised"|"ocaml.specialised")} when Config.flambda -> true
-  | _ -> false
-
-let is_local_attribute = function
-  | {txt=("local"|"ocaml.local")} -> true
-  | _ -> false
-
-let find_attribute p attributes =
-  let inline_attribute, other_attributes =
-    List.partition (fun a -> p a.Parsetree.attr_name) attributes
-  in
-  let attr =
-    match inline_attribute with
-    | [] -> None
-    | [attr] -> Some attr
-    | _ :: {Parsetree.attr_name = {txt;loc}; _} :: _ ->
-      Location.prerr_warning loc (Warnings.Duplicated_attribute txt);
-      None
-  in
-  attr, other_attributes
-
-let is_unrolled = function
-  | {txt="unrolled"|"ocaml.unrolled"} -> true
-  | {txt="inline"|"ocaml.inline"|"inlined"|"ocaml.inlined"} -> false
-  | _ -> assert false
-
-let get_id_payload =
-  let open Parsetree in
-  function
-  | PStr [] -> Some ""
-  | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] ->
-      begin match pexp_desc with
-      | Pexp_ident { txt = Longident.Lident id } -> Some id
-      | _ -> None
-      end
-  | _ -> None
-
-let parse_id_payload txt loc ~default ~empty cases payload =
-  let[@local] warn () =
-    let ( %> ) f g x = g (f x) in
-    let msg =
-      cases
-      |> List.map (fst %> Printf.sprintf "'%s'")
-      |> String.concat ", "
-      |> Printf.sprintf "It must be either %s or empty"
-    in
-    Location.prerr_warning loc (Warnings.Attribute_payload (txt, msg));
-    default
-  in
-  match get_id_payload payload with
-  | Some "" -> empty
-  | None -> warn ()
-  | Some id ->
-      match List.assoc_opt id cases with
-      | Some r -> r
-      | None -> warn ()
-
-let parse_inline_attribute attr =
-  match attr with
-  | None -> Default_inline
-  | Some {Parsetree.attr_name = {txt;loc} as id; attr_payload = payload} ->
-    let open Parsetree in
-    if is_unrolled id then begin
-      (* the 'unrolled' attributes must be used as [@unrolled n]. *)
-      let warning txt = Warnings.Attribute_payload
-          (txt, "It must be an integer literal")
-      in
-      match payload with
-      | PStr [{pstr_desc = Pstr_eval ({pexp_desc},[])}] -> begin
-          match pexp_desc with
-          | Pexp_constant (Pconst_integer(s, None)) -> begin
-              try
-                Unroll (Misc.Int_literal_converter.int s)
-              with Failure _ ->
-                Location.prerr_warning loc (warning txt);
-                Default_inline
-            end
-          | _ ->
-            Location.prerr_warning loc (warning txt);
-            Default_inline
-        end
-      | _ ->
-        Location.prerr_warning loc (warning txt);
-        Default_inline
-    end else
-      parse_id_payload txt loc
-        ~default:Default_inline
-        ~empty:Always_inline
-        [
-          "never", Never_inline;
-          "always", Always_inline;
-        ]
-        payload
-
-let parse_specialise_attribute attr =
-  match attr with
-  | None -> Default_specialise
-  | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} ->
-      parse_id_payload txt loc
-        ~default:Default_specialise
-        ~empty:Always_specialise
-        [
-          "never", Never_specialise;
-          "always", Always_specialise;
-        ]
-        payload
-
-let parse_local_attribute attr =
-  match attr with
-  | None -> Default_local
-  | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} ->
-      parse_id_payload txt loc
-        ~default:Default_local
-        ~empty:Always_local
-        [
-          "never", Never_local;
-          "always", Always_local;
-          "maybe", Default_local;
-        ]
-        payload
-
-let get_inline_attribute l =
-  let attr, _ = find_attribute is_inline_attribute l in
-  parse_inline_attribute attr
-
-let get_specialise_attribute l =
-  let attr, _ = find_attribute is_specialise_attribute l in
-  parse_specialise_attribute attr
-
-let get_local_attribute l =
-  let attr, _ = find_attribute is_local_attribute l in
-  parse_local_attribute attr
-
-let check_local_inline loc attr =
-  match attr.local, attr.inline with
-  | Always_local, (Always_inline | Unroll _) ->
-      Location.prerr_warning loc
-        (Warnings.Duplicated_attribute "local/inline")
-  | _ ->
-      ()
-
-let add_inline_attribute expr loc attributes =
-  match expr, get_inline_attribute attributes with
-  | expr, Default_inline -> expr
-  | Lfunction({ attr = { stub = false } as attr } as funct), inline ->
-      begin match attr.inline with
-      | Default_inline -> ()
-      | Always_inline | Never_inline | Unroll _ ->
-          Location.prerr_warning loc
-            (Warnings.Duplicated_attribute "inline")
-      end;
-      let attr = { attr with inline } in
-      check_local_inline loc attr;
-      Lfunction { funct with attr = attr }
-  | expr, (Always_inline | Never_inline | Unroll _) ->
-      Location.prerr_warning loc
-        (Warnings.Misplaced_attribute "inline");
-      expr
-
-let add_specialise_attribute expr loc attributes =
-  match expr, get_specialise_attribute attributes with
-  | expr, Default_specialise -> expr
-  | Lfunction({ attr = { stub = false } as attr } as funct), specialise ->
-      begin match attr.specialise with
-      | Default_specialise -> ()
-      | Always_specialise | Never_specialise ->
-          Location.prerr_warning loc
-            (Warnings.Duplicated_attribute "specialise")
-      end;
-      let attr = { attr with specialise } in
-      Lfunction { funct with attr }
-  | expr, (Always_specialise | Never_specialise) ->
-      Location.prerr_warning loc
-        (Warnings.Misplaced_attribute "specialise");
-      expr
-
-let add_local_attribute expr loc attributes =
-  match expr, get_local_attribute attributes with
-  | expr, Default_local -> expr
-  | Lfunction({ attr = { stub = false } as attr } as funct), local ->
-      begin match attr.local with
-      | Default_local -> ()
-      | Always_local | Never_local ->
-          Location.prerr_warning loc
-            (Warnings.Duplicated_attribute "local")
-      end;
-      let attr = { attr with local } in
-      check_local_inline loc attr;
-      Lfunction { funct with attr }
-  | expr, (Always_local | Never_local) ->
-      Location.prerr_warning loc
-        (Warnings.Misplaced_attribute "local");
-      expr
-
-(* Get the [@inlined] attribute payload (or default if not present).
-   It also returns the expression without this attribute. This is
-   used to ensure that this attribute is not misplaced: If it
-   appears on any expression, it is an error, otherwise it would
-   have been removed by this function *)
-let get_and_remove_inlined_attribute e =
-  let attr, exp_attributes =
-    find_attribute is_inlined_attribute e.exp_attributes
-  in
-  let inlined = parse_inline_attribute attr in
-  inlined, { e with exp_attributes }
-
-let get_and_remove_inlined_attribute_on_module e =
-  let rec get_and_remove mod_expr =
-    let attr, mod_attributes =
-      find_attribute is_inlined_attribute mod_expr.mod_attributes
-    in
-    let attr = parse_inline_attribute attr in
-    let attr, mod_desc =
-      match mod_expr.Typedtree.mod_desc with
-      | Tmod_constraint (me, mt, mtc, mc) ->
-        let inner_attr, me = get_and_remove me in
-        let attr =
-          match attr with
-          | Always_inline | Never_inline | Unroll _ -> attr
-          | Default_inline -> inner_attr
-        in
-        attr, Tmod_constraint (me, mt, mtc, mc)
-      | md -> attr, md
-    in
-    attr, { mod_expr with mod_desc; mod_attributes }
-  in
-  get_and_remove e
-
-let get_and_remove_specialised_attribute e =
-  let attr, exp_attributes =
-    find_attribute is_specialised_attribute e.exp_attributes
-  in
-  let specialised = parse_specialise_attribute attr in
-  specialised, { e with exp_attributes }
-
-(* It also removes the attribute from the expression, like
-   get_inlined_attribute *)
-let get_tailcall_attribute e =
-  let is_tailcall_attribute = function
-    | {Parsetree.attr_name = {txt=("tailcall"|"ocaml.tailcall")}; _} -> true
-    | _ -> false
-  in
-  let tailcalls, exp_attributes =
-    List.partition is_tailcall_attribute e.exp_attributes
-  in
-  match tailcalls with
-  | [] -> false, e
-  | _ :: r ->
-      begin match r with
-      | [] -> ()
-      | {Parsetree.attr_name = {txt;loc}; _} :: _ ->
-          Location.prerr_warning loc (Warnings.Duplicated_attribute txt)
-      end;
-      true, { e with exp_attributes }
-
-let check_attribute e {Parsetree.attr_name = { txt; loc }; _} =
-  match txt with
-  | "inline" | "ocaml.inline"
-  | "specialise" | "ocaml.specialise" -> begin
-      match e.exp_desc with
-      | Texp_function _ -> ()
-      | _ ->
-          Location.prerr_warning loc
-            (Warnings.Misplaced_attribute txt)
-    end
-  | "inlined" | "ocaml.inlined"
-  | "specialised" | "ocaml.specialised"
-  | "tailcall" | "ocaml.tailcall" ->
-      (* Removed by the Texp_apply cases *)
-      Location.prerr_warning loc
-        (Warnings.Misplaced_attribute txt)
-  | _ -> ()
-
-let check_attribute_on_module e {Parsetree.attr_name = { txt; loc }; _} =
-  match txt with
-  | "inline" | "ocaml.inline" ->  begin
-      match e.mod_desc with
-      | Tmod_functor _ -> ()
-      | _ ->
-          Location.prerr_warning loc
-            (Warnings.Misplaced_attribute txt)
-    end
-  | "inlined" | "ocaml.inlined" ->
-      (* Removed by the Texp_apply cases *)
-      Location.prerr_warning loc
-        (Warnings.Misplaced_attribute txt)
-  | _ -> ()
-
-let add_function_attributes lam loc attr =
-  let lam =
-    add_inline_attribute lam loc attr
-  in
-  let lam =
-    add_specialise_attribute lam loc attr
-  in
-  let lam =
-    add_local_attribute lam loc attr
-  in
-  lam
diff --git a/bytecomp/translattribute.mli b/bytecomp/translattribute.mli
deleted file mode 100644
index bf22fd1c5d..0000000000
--- a/bytecomp/translattribute.mli
+++ /dev/null
@@ -1,76 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*                      Pierre Chambart, OCamlPro                         *)
-(*                                                                        *)
-(*   Copyright 2015 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.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-val check_attribute
-   : Typedtree.expression
-  -> Parsetree.attribute
-  -> unit
-
-val check_attribute_on_module
-   : Typedtree.module_expr
-  -> Parsetree.attribute
-  -> unit
-
-val add_inline_attribute
-   : Lambda.lambda
-  -> Location.t
-  -> Parsetree.attributes
-  -> Lambda.lambda
-
-val get_inline_attribute
-   : Parsetree.attributes
-  -> Lambda.inline_attribute
-
-val add_specialise_attribute
-   : Lambda.lambda
-  -> Location.t
-  -> Parsetree.attributes
-  -> Lambda.lambda
-
-val get_specialise_attribute
-   : Parsetree.attributes
-  -> Lambda.specialise_attribute
-
-val add_local_attribute
-   : Lambda.lambda
-  -> Location.t
-  -> Parsetree.attributes
-  -> Lambda.lambda
-
-val get_local_attribute
-   : Parsetree.attributes
-  -> Lambda.local_attribute
-
-val get_and_remove_inlined_attribute
-   : Typedtree.expression
-  -> Lambda.inline_attribute * Typedtree.expression
-
-val get_and_remove_inlined_attribute_on_module
-   : Typedtree.module_expr
-  -> Lambda.inline_attribute * Typedtree.module_expr
-
-val get_and_remove_specialised_attribute
-   : Typedtree.expression
-  -> Lambda.specialise_attribute * Typedtree.expression
-
-val get_tailcall_attribute
-   : Typedtree.expression
-  -> bool * Typedtree.expression
-
-val add_function_attributes
-  : Lambda.lambda
-  -> Location.t
-  -> Parsetree.attributes
-  -> Lambda.lambda
diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml
deleted file mode 100644
index 10b09066d7..0000000000
--- a/bytecomp/translclass.ml
+++ /dev/null
@@ -1,946 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*          Jerome Vouillon, 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 Asttypes
-open Types
-open Typedtree
-open Lambda
-open Translobj
-open Translcore
-
-(* XXX Rajouter des evenements... | Add more events... *)
-
-type error = Tags of label * label
-
-exception Error of Location.t * error
-
-let lfunction params body =
-  if params = [] then body else
-  match body with
-  | Lfunction {kind = Curried; params = params'; body = body'; attr; loc} ->
-      Lfunction {kind = Curried; params = params @ params';
-                 return = Pgenval;
-                 body = body'; attr;
-                 loc}
-  |  _ ->
-      Lfunction {kind = Curried; params; return = Pgenval;
-                 body;
-                 attr = default_function_attribute;
-                 loc = Location.none}
-
-let lapply ap =
-  match ap.ap_func with
-    Lapply ap' ->
-      Lapply {ap with ap_func = ap'.ap_func; ap_args = ap'.ap_args @ ap.ap_args}
-  | _ ->
-      Lapply ap
-
-let mkappl (func, args) =
-  Lapply {ap_should_be_tailcall=false;
-          ap_loc=Location.none;
-          ap_func=func;
-          ap_args=args;
-          ap_inlined=Default_inline;
-          ap_specialised=Default_specialise};;
-
-let lsequence l1 l2 =
-  if l2 = lambda_unit then l1 else Lsequence(l1, l2)
-
-let lfield v i = Lprim(Pfield i, [Lvar v], Location.none)
-
-let transl_label l = share (Const_immstring l)
-
-let transl_meth_list lst =
-  if lst = [] then Lconst (Const_pointer 0) else
-  share (Const_block
-            (0, List.map (fun lab -> Const_immstring lab) lst))
-
-let set_inst_var obj id expr =
-  Lprim(Psetfield_computed (Typeopt.maybe_pointer expr, Assignment),
-    [Lvar obj; Lvar id; transl_exp expr], Location.none)
-
-let transl_val tbl create name =
-  mkappl (oo_prim (if create then "new_variable" else "get_variable"),
-          [Lvar tbl; transl_label name])
-
-let transl_vals tbl create strict vals rem =
-  List.fold_right
-    (fun (name, id) rem ->
-      Llet(strict, Pgenval, id, transl_val tbl create name, rem))
-    vals rem
-
-let meths_super tbl meths inh_meths =
-  List.fold_right
-    (fun (nm, id) rem ->
-       try
-         (nm, id,
-          mkappl(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
-         :: rem
-       with Not_found -> rem)
-    inh_meths []
-
-let bind_super tbl (vals, meths) cl_init =
-  transl_vals tbl false StrictOpt vals
-    (List.fold_right (fun (_nm, id, def) rem ->
-         Llet(StrictOpt, Pgenval, id, def, rem))
-       meths cl_init)
-
-let create_object cl obj init =
-  let obj' = Ident.create_local "self" in
-  let (inh_init, obj_init, has_init) = init obj' in
-  if obj_init = lambda_unit then
-    (inh_init,
-     mkappl (oo_prim (if has_init then "create_object_and_run_initializers"
-                      else"create_object_opt"),
-             [obj; Lvar cl]))
-  else begin
-   (inh_init,
-    Llet(Strict, Pgenval, obj',
-            mkappl (oo_prim "create_object_opt", [obj; Lvar cl]),
-         Lsequence(obj_init,
-                   if not has_init then Lvar obj' else
-                   mkappl (oo_prim "run_initializers_opt",
-                           [obj; Lvar obj'; Lvar cl]))))
-  end
-
-let name_pattern default p =
-  match p.pat_desc with
-  | Tpat_var (id, _) -> id
-  | Tpat_alias(_, id, _) -> id
-  | _ -> Ident.create_local default
-
-let rec build_object_init cl_table obj params inh_init obj_init cl =
-  match cl.cl_desc with
-    Tcl_ident (path, _, _) ->
-      let obj_init = Ident.create_local "obj_init" in
-      let envs, inh_init = inh_init in
-      let env =
-        match envs with None -> []
-        | Some envs ->
-            [Lprim(Pfield (List.length inh_init + 1),
-                   [Lvar envs],
-                   Location.none)]
-      in
-      let path_lam = transl_class_path cl.cl_loc cl.cl_env path in
-      ((envs, (path, path_lam, obj_init) :: inh_init),
-       mkappl(Lvar obj_init, env @ [obj]))
-  | Tcl_structure str ->
-      create_object cl_table obj (fun obj ->
-        let (inh_init, obj_init, has_init) =
-          List.fold_right
-            (fun field (inh_init, obj_init, has_init) ->
-               match field.cf_desc with
-                 Tcf_inherit (_, cl, _, _, _) ->
-                   let (inh_init, obj_init') =
-                     build_object_init cl_table (Lvar obj) [] inh_init
-                       (fun _ -> lambda_unit) cl
-                   in
-                   (inh_init, lsequence obj_init' obj_init, true)
-               | Tcf_val (_, _, id, Tcfk_concrete (_, exp), _) ->
-                   (inh_init, lsequence (set_inst_var obj id exp) obj_init,
-                    has_init)
-               | Tcf_method _ | Tcf_val _ | Tcf_constraint _ | Tcf_attribute _->
-                   (inh_init, obj_init, has_init)
-               | Tcf_initializer _ ->
-                   (inh_init, obj_init, true)
-            )
-            str.cstr_fields
-            (inh_init, obj_init obj, false)
-        in
-        (inh_init,
-         List.fold_right
-           (fun (id, expr) rem ->
-              lsequence (Lifused (id, set_inst_var obj id expr)) rem)
-           params obj_init,
-         has_init))
-  | Tcl_fun (_, pat, vals, cl, partial) ->
-      let (inh_init, obj_init) =
-        build_object_init cl_table obj (vals @ params) inh_init obj_init cl
-      in
-      (inh_init,
-       let build params rem =
-         let param = name_pattern "param" pat in
-         Lfunction {kind = Curried; params = (param, Pgenval)::params;
-                    return = Pgenval;
-                    attr = default_function_attribute;
-                    loc = pat.pat_loc;
-                    body = Matching.for_function
-                             pat.pat_loc None (Lvar param) [pat, rem] partial}
-       in
-       begin match obj_init with
-         Lfunction {kind = Curried; params; body = rem} -> build params rem
-       | rem                                            -> build [] rem
-       end)
-  | Tcl_apply (cl, oexprs) ->
-      let (inh_init, obj_init) =
-        build_object_init cl_table obj params inh_init obj_init cl
-      in
-      (inh_init, transl_apply obj_init oexprs Location.none)
-  | Tcl_let (rec_flag, defs, vals, cl) ->
-      let (inh_init, obj_init) =
-        build_object_init cl_table obj (vals @ params) inh_init obj_init cl
-      in
-      (inh_init, Translcore.transl_let rec_flag defs obj_init)
-  | Tcl_open (_, cl)
-  | Tcl_constraint (cl, _, _, _, _) ->
-      build_object_init cl_table obj params inh_init obj_init cl
-
-let rec build_object_init_0 cl_table params cl copy_env subst_env top ids =
-  match cl.cl_desc with
-    Tcl_let (_rec_flag, _defs, vals, cl) ->
-      build_object_init_0 cl_table (vals@params) cl copy_env subst_env top ids
-  | _ ->
-      let self = Ident.create_local "self" in
-      let env = Ident.create_local "env" in
-      let obj = if ids = [] then lambda_unit else Lvar self in
-      let envs = if top then None else Some env in
-      let ((_,inh_init), obj_init) =
-        build_object_init cl_table obj params (envs,[]) copy_env cl in
-      let obj_init =
-        if ids = [] then obj_init else lfunction [self, Pgenval] obj_init in
-      (inh_init, lfunction [env, Pgenval] (subst_env env inh_init obj_init))
-
-
-let bind_method tbl lab id cl_init =
-  Llet(Strict, Pgenval, id, mkappl (oo_prim "get_method_label",
-                           [Lvar tbl; transl_label lab]),
-       cl_init)
-
-let bind_methods tbl meths vals cl_init =
-  let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in
-  let len = List.length methl and nvals = List.length vals in
-  if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
-  if len = 0 && nvals < 2 then transl_vals tbl true Strict vals cl_init else
-  let ids = Ident.create_local "ids" in
-  let i = ref (len + nvals) in
-  let getter, names =
-    if nvals = 0 then "get_method_labels", [] else
-    "new_methods_variables", [transl_meth_list (List.map fst vals)]
-  in
-  Llet(Strict, Pgenval, ids,
-       mkappl (oo_prim getter,
-               [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
-       List.fold_right
-         (fun (_lab,id) lam -> decr i; Llet(StrictOpt, Pgenval, id,
-                                           lfield ids !i, lam))
-         (methl @ vals) cl_init)
-
-let output_methods tbl methods lam =
-  match methods with
-    [] -> lam
-  | [lab; code] ->
-      lsequence (mkappl(oo_prim "set_method", [Lvar tbl; lab; code])) lam
-  | _ ->
-      lsequence (mkappl(oo_prim "set_methods",
-                        [Lvar tbl; Lprim(Pmakeblock(0,Immutable,None),
-                                         methods, Location.none)]))
-        lam
-
-let rec ignore_cstrs cl =
-  match cl.cl_desc with
-    Tcl_constraint (cl, _, _, _, _) -> ignore_cstrs cl
-  | Tcl_apply (cl, _) -> ignore_cstrs cl
-  | _ -> cl
-
-let rec index a = function
-    [] -> raise Not_found
-  | b :: l ->
-      if b = a then 0 else 1 + index a l
-
-let bind_id_as_val (id, _) = ("", id)
-
-let rec build_class_init cla cstr super inh_init cl_init msubst top cl =
-  match cl.cl_desc with
-  | Tcl_ident _ ->
-      begin match inh_init with
-      | (_, path_lam, obj_init)::inh_init ->
-          (inh_init,
-           Llet (Strict, Pgenval, obj_init,
-                 mkappl(Lprim(Pfield 1, [path_lam], Location.none), Lvar cla ::
-                        if top then [Lprim(Pfield 3, [path_lam], Location.none)]
-                        else []),
-                 bind_super cla super cl_init))
-      | _ ->
-          assert false
-      end
-  | Tcl_structure str ->
-      let cl_init = bind_super cla super cl_init in
-      let (inh_init, cl_init, methods, values) =
-        List.fold_right
-          (fun field (inh_init, cl_init, methods, values) ->
-            match field.cf_desc with
-              Tcf_inherit (_, cl, _, vals, meths) ->
-                let cl_init = output_methods cla methods cl_init in
-                let inh_init, cl_init =
-                  build_class_init cla false
-                    (vals, meths_super cla str.cstr_meths meths)
-                    inh_init cl_init msubst top cl in
-                (inh_init, cl_init, [], values)
-            | Tcf_val (name, _, id, _, over) ->
-                let values =
-                  if over then values else (name.txt, id) :: values
-                in
-                (inh_init, cl_init, methods, values)
-            | Tcf_method (_, _, Tcfk_virtual _)
-            | Tcf_constraint _
-              ->
-                (inh_init, cl_init, methods, values)
-            | Tcf_method (name, _, Tcfk_concrete (_, exp)) ->
-                let met_code = msubst true (transl_exp exp) in
-                let met_code =
-                  if !Clflags.native_code && List.length met_code = 1 then
-                    (* Force correct naming of method for profiles *)
-                    let met = Ident.create_local ("method_" ^ name.txt) in
-                    [Llet(Strict, Pgenval, met, List.hd met_code, Lvar met)]
-                  else met_code
-                in
-                (inh_init, cl_init,
-                 Lvar(Meths.find name.txt str.cstr_meths) :: met_code @ methods,
-                 values)
-            | Tcf_initializer exp ->
-                (inh_init,
-                 Lsequence(mkappl (oo_prim "add_initializer",
-                                   Lvar cla :: msubst false (transl_exp exp)),
-                           cl_init),
-                 methods, values)
-            | Tcf_attribute _ ->
-                (inh_init, cl_init, methods, values))
-          str.cstr_fields
-          (inh_init, cl_init, [], [])
-      in
-      let cl_init = output_methods cla methods cl_init in
-      (inh_init, bind_methods cla str.cstr_meths values cl_init)
-  | Tcl_fun (_, _pat, vals, cl, _) ->
-      let (inh_init, cl_init) =
-        build_class_init cla cstr super inh_init cl_init msubst top cl
-      in
-      let vals = List.map bind_id_as_val vals in
-      (inh_init, transl_vals cla true StrictOpt vals cl_init)
-  | Tcl_apply (cl, _exprs) ->
-      build_class_init cla cstr super inh_init cl_init msubst top cl
-  | Tcl_let (_rec_flag, _defs, vals, cl) ->
-      let (inh_init, cl_init) =
-        build_class_init cla cstr super inh_init cl_init msubst top cl
-      in
-      let vals = List.map bind_id_as_val vals in
-      (inh_init, transl_vals cla true StrictOpt vals cl_init)
-  | Tcl_constraint (cl, _, vals, meths, concr_meths) ->
-      let virt_meths =
-        List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
-      let concr_meths = Concr.elements concr_meths in
-      let narrow_args =
-        [Lvar cla;
-         transl_meth_list vals;
-         transl_meth_list virt_meths;
-         transl_meth_list concr_meths] in
-      let cl = ignore_cstrs cl in
-      begin match cl.cl_desc, inh_init with
-      | Tcl_ident (path, _, _), (path', path_lam, obj_init)::inh_init ->
-          assert (Path.same path path');
-          let inh = Ident.create_local "inh"
-          and ofs = List.length vals + 1
-          and valids, methids = super in
-          let cl_init =
-            List.fold_left
-              (fun init (nm, id, _) ->
-                Llet(StrictOpt, Pgenval, id,
-                     lfield inh (index nm concr_meths + ofs),
-                     init))
-              cl_init methids in
-          let cl_init =
-            List.fold_left
-              (fun init (nm, id) ->
-                Llet(StrictOpt, Pgenval, id,
-                     lfield inh (index nm vals + 1), init))
-              cl_init valids in
-          (inh_init,
-           Llet (Strict, Pgenval, inh,
-                 mkappl(oo_prim "inherits", narrow_args @
-                        [path_lam;
-                         Lconst(Const_pointer(if top then 1 else 0))]),
-                 Llet(StrictOpt, Pgenval, obj_init, lfield inh 0, cl_init)))
-      | _ ->
-          let core cl_init =
-            build_class_init cla true super inh_init cl_init msubst top cl
-          in
-          if cstr then core cl_init else
-          let (inh_init, cl_init) =
-            core (Lsequence (mkappl (oo_prim "widen", [Lvar cla]), cl_init))
-          in
-          (inh_init,
-           Lsequence(mkappl (oo_prim "narrow", narrow_args),
-                     cl_init))
-      end
-  | Tcl_open (_, cl) ->
-      build_class_init cla cstr super inh_init cl_init msubst top cl
-
-let rec build_class_lets cl =
-  match cl.cl_desc with
-    Tcl_let (rec_flag, defs, _vals, cl') ->
-      let env, wrap = build_class_lets cl' in
-      (env, fun x ->
-          Translcore.transl_let rec_flag defs (wrap x))
-  | _ ->
-      (cl.cl_env, fun x -> x)
-
-let rec get_class_meths cl =
-  match cl.cl_desc with
-    Tcl_structure cl ->
-      Meths.fold (fun _ -> Ident.Set.add) cl.cstr_meths Ident.Set.empty
-  | Tcl_ident _ -> Ident.Set.empty
-  | Tcl_fun (_, _, _, cl, _)
-  | Tcl_let (_, _, _, cl)
-  | Tcl_apply (cl, _)
-  | Tcl_open (_, cl)
-  | Tcl_constraint (cl, _, _, _, _) -> get_class_meths cl
-
-(*
-   XXX Il devrait etre peu couteux d'ecrire des classes :
-   |   Writing classes should be cheap
-     class c x y = d e f
-*)
-let rec transl_class_rebind obj_init cl vf =
-  match cl.cl_desc with
-    Tcl_ident (path, _, _) ->
-      if vf = Concrete then begin
-        try if (Env.find_class path cl.cl_env).cty_new = None then raise Exit
-        with Not_found -> raise Exit
-      end;
-      let path_lam = transl_class_path cl.cl_loc cl.cl_env path in
-      (path, path_lam, obj_init)
-  | Tcl_fun (_, pat, _, cl, partial) ->
-      let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in
-      let build params rem =
-        let param = name_pattern "param" pat in
-        Lfunction {kind = Curried; params = (param, Pgenval)::params;
-                   return = Pgenval;
-                   attr = default_function_attribute;
-                   loc = pat.pat_loc;
-                   body = Matching.for_function
-                            pat.pat_loc None (Lvar param) [pat, rem] partial}
-      in
-      (path, path_lam,
-       match obj_init with
-         Lfunction {kind = Curried; params; body} -> build params body
-       | rem                                      -> build [] rem)
-  | Tcl_apply (cl, oexprs) ->
-      let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in
-      (path, path_lam, transl_apply obj_init oexprs Location.none)
-  | Tcl_let (rec_flag, defs, _vals, cl) ->
-      let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in
-      (path, path_lam, Translcore.transl_let rec_flag defs obj_init)
-  | Tcl_structure _ -> raise Exit
-  | Tcl_constraint (cl', _, _, _, _) ->
-      let path, path_lam, obj_init = transl_class_rebind obj_init cl' vf in
-      let rec check_constraint = function
-          Cty_constr(path', _, _) when Path.same path path' -> ()
-        | Cty_arrow (_, _, cty) -> check_constraint cty
-        | _ -> raise Exit
-      in
-      check_constraint cl.cl_type;
-      (path, path_lam, obj_init)
-  | Tcl_open (_, cl) ->
-      transl_class_rebind obj_init cl vf
-
-let rec transl_class_rebind_0 (self:Ident.t) obj_init cl vf =
-  match cl.cl_desc with
-    Tcl_let (rec_flag, defs, _vals, cl) ->
-      let path, path_lam, obj_init =
-        transl_class_rebind_0 self obj_init cl vf
-      in
-      (path, path_lam, Translcore.transl_let rec_flag defs obj_init)
-  | _ ->
-      let path, path_lam, obj_init = transl_class_rebind obj_init cl vf in
-      (path, path_lam, lfunction [self, Pgenval] obj_init)
-
-let transl_class_rebind cl vf =
-  try
-    let obj_init = Ident.create_local "obj_init"
-    and self = Ident.create_local "self" in
-    let obj_init0 =
-      lapply {ap_should_be_tailcall=false;
-              ap_loc=Location.none;
-              ap_func=Lvar obj_init;
-              ap_args=[Lvar self];
-              ap_inlined=Default_inline;
-              ap_specialised=Default_specialise}
-    in
-    let _, path_lam, obj_init' = transl_class_rebind_0 self obj_init0 cl vf in
-    let id = (obj_init' = lfunction [self, Pgenval] obj_init0) in
-    if id then path_lam else
-
-    let cla = Ident.create_local "class"
-    and new_init = Ident.create_local "new_init"
-    and env_init = Ident.create_local "env_init"
-    and table = Ident.create_local "table"
-    and envs = Ident.create_local "envs" in
-    Llet(
-    Strict, Pgenval, new_init, lfunction [obj_init, Pgenval] obj_init',
-    Llet(
-    Alias, Pgenval, cla, path_lam,
-    Lprim(Pmakeblock(0, Immutable, None),
-          [mkappl(Lvar new_init, [lfield cla 0]);
-           lfunction [table, Pgenval]
-             (Llet(Strict, Pgenval, env_init,
-                   mkappl(lfield cla 1, [Lvar table]),
-                   lfunction [envs, Pgenval]
-                     (mkappl(Lvar new_init,
-                             [mkappl(Lvar env_init, [Lvar envs])]))));
-           lfield cla 2;
-           lfield cla 3],
-          Location.none)))
-  with Exit ->
-    lambda_unit
-
-(* Rewrite a closure using builtins. Improves native code size. *)
-
-let rec module_path = function
-    Lvar id ->
-      let s = Ident.name id in s <> "" && s.[0] >= 'A' && s.[0] <= 'Z'
-  | Lprim(Pfield _, [p], _)    -> module_path p
-  | Lprim(Pgetglobal _, [], _) -> true
-  | _                          -> false
-
-let const_path local = function
-    Lvar id -> not (List.mem id local)
-  | Lconst _ -> true
-  | Lfunction {kind = Curried; body} ->
-      let fv = free_variables body in
-      List.for_all (fun x -> not (Ident.Set.mem x fv)) local
-  | p -> module_path p
-
-let rec builtin_meths self env env2 body =
-  let const_path = const_path (env::self) in
-  let conv = function
-    (* Lvar s when List.mem s self ->  "_self", [] *)
-    | p when const_path p -> "const", [p]
-    | Lprim(Parrayrefu _, [Lvar s; Lvar n], _) when List.mem s self ->
-        "var", [Lvar n]
-    | Lprim(Pfield n, [Lvar e], _) when Ident.same e env ->
-        "env", [Lvar env2; Lconst(Const_pointer n)]
-    | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
-        "meth", [met]
-    | _ -> raise Not_found
-  in
-  match body with
-  | Llet(_str, _k, s', Lvar s, body) when List.mem s self ->
-      builtin_meths (s'::self) env env2 body
-  | Lapply{ap_func = f; ap_args = [arg]} when const_path f ->
-      let s, args = conv arg in ("app_"^s, f :: args)
-  | Lapply{ap_func = f; ap_args = [arg; p]} when const_path f && const_path p ->
-      let s, args = conv arg in
-      ("app_"^s^"_const", f :: args @ [p])
-  | Lapply{ap_func = f; ap_args = [p; arg]} when const_path f && const_path p ->
-      let s, args = conv arg in
-      ("app_const_"^s, f :: p :: args)
-  | Lsend(Self, Lvar n, Lvar s, [arg], _) when List.mem s self ->
-      let s, args = conv arg in
-      ("meth_app_"^s, Lvar n :: args)
-  | Lsend(Self, met, Lvar s, [], _) when List.mem s self ->
-      ("get_meth", [met])
-  | Lsend(Public, met, arg, [], _) ->
-      let s, args = conv arg in
-      ("send_"^s, met :: args)
-  | Lsend(Cached, met, arg, [_;_], _) ->
-      let s, args = conv arg in
-      ("send_"^s, met :: args)
-  | Lfunction {kind = Curried; params = [x, _]; body} ->
-      let rec enter self = function
-        | Lprim(Parraysetu _, [Lvar s; Lvar n; Lvar x'], _)
-          when Ident.same x x' && List.mem s self ->
-            ("set_var", [Lvar n])
-        | Llet(_str, _k, s', Lvar s, body) when List.mem s self ->
-            enter (s'::self) body
-        | _ -> raise Not_found
-      in enter self body
-  | Lfunction _ -> raise Not_found
-  | _ ->
-      let s, args = conv body in ("get_"^s, args)
-
-module M = struct
-  open CamlinternalOO
-  let builtin_meths self env env2 body =
-    let builtin, args = builtin_meths self env env2 body in
-    (* if not arr then [mkappl(oo_prim builtin, args)] else *)
-    let tag = match builtin with
-      "get_const" -> GetConst
-    | "get_var"   -> GetVar
-    | "get_env"   -> GetEnv
-    | "get_meth"  -> GetMeth
-    | "set_var"   -> SetVar
-    | "app_const" -> AppConst
-    | "app_var"   -> AppVar
-    | "app_env"   -> AppEnv
-    | "app_meth"  -> AppMeth
-    | "app_const_const" -> AppConstConst
-    | "app_const_var"   -> AppConstVar
-    | "app_const_env"   -> AppConstEnv
-    | "app_const_meth"  -> AppConstMeth
-    | "app_var_const"   -> AppVarConst
-    | "app_env_const"   -> AppEnvConst
-    | "app_meth_const"  -> AppMethConst
-    | "meth_app_const"  -> MethAppConst
-    | "meth_app_var"    -> MethAppVar
-    | "meth_app_env"    -> MethAppEnv
-    | "meth_app_meth"   -> MethAppMeth
-    | "send_const" -> SendConst
-    | "send_var"   -> SendVar
-    | "send_env"   -> SendEnv
-    | "send_meth"  -> SendMeth
-    | _ -> assert false
-    in Lconst(Const_pointer(Obj.magic tag)) :: args
-end
-open M
-
-
-(*
-   Class translation.
-   Three subcases:
-    * reapplication of a known class -> transl_class_rebind
-    * class without local dependencies -> direct translation
-    * with local dependencies -> generate a stubs tree,
-      with a node for every local classes inherited
-   A class is a 4-tuple:
-    (obj_init, class_init, env_init, env)
-    obj_init: creation function (unit -> obj)
-    class_init: inheritance function (table -> env_init)
-      (one by source code)
-    env_init: parameterisation by the local environment
-      (env -> params -> obj_init)
-      (one for each combination of inherited class_init )
-    env: local environment
-   If ids=0 (immediate object), then only env_init is conserved.
-*)
-
-(*
-let prerr_ids msg ids =
-  let names = List.map Ident.unique_toplevel_name ids in
-  prerr_endline (String.concat " " (msg :: names))
-*)
-
-let free_methods l =
-  let fv = ref Ident.Set.empty in
-  let rec free l =
-    Lambda.iter_head_constructor free l;
-    match l with
-    | Lsend(Self, Lvar meth, _, _, _) ->
-        fv := Ident.Set.add meth !fv
-    | Lsend _ -> ()
-    | Lfunction{params} ->
-        List.iter (fun (param, _) -> fv := Ident.Set.remove param !fv) params
-    | Llet(_str, _k, id, _arg, _body) ->
-        fv := Ident.Set.remove id !fv
-    | Lletrec(decl, _body) ->
-        List.iter (fun (id, _exp) -> fv := Ident.Set.remove id !fv) decl
-    | Lstaticcatch(_e1, (_,vars), _e2) ->
-        List.iter (fun (id, _) -> fv := Ident.Set.remove id !fv) vars
-    | Ltrywith(_e1, exn, _e2) ->
-        fv := Ident.Set.remove exn !fv
-    | Lfor(v, _e1, _e2, _dir, _e3) ->
-        fv := Ident.Set.remove v !fv
-    | Lassign _
-    | Lvar _ | Lconst _ | Lapply _
-    | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _
-    | Lifthenelse _ | Lsequence _ | Lwhile _
-    | Levent _ | Lifused _ -> ()
-  in free l; !fv
-
-let transl_class ids cl_id pub_meths cl vflag =
-  (* First check if it is not only a rebind *)
-  let rebind = transl_class_rebind cl vflag in
-  if rebind <> lambda_unit then rebind else
-
-  (* Prepare for heavy environment handling *)
-  let tables = Ident.create_local (Ident.name cl_id ^ "_tables") in
-  let (top_env, req) = oo_add_class tables in
-  let top = not req in
-  let cl_env, llets = build_class_lets cl in
-  let new_ids = if top then [] else Env.diff top_env cl_env in
-  let env2 = Ident.create_local "env" in
-  let meth_ids = get_class_meths cl in
-  let subst env lam i0 new_ids' =
-    let fv = free_variables lam in
-    (* prerr_ids "cl_id =" [cl_id]; prerr_ids "fv =" (Ident.Set.elements fv); *)
-    let fv = List.fold_right Ident.Set.remove !new_ids' fv in
-    (* We need to handle method ids specially, as they do not appear
-       in the typing environment (PR#3576, PR#4560) *)
-    (* very hacky: we add and remove free method ids on the fly,
-       depending on the visit order... *)
-    method_ids :=
-      Ident.Set.diff (Ident.Set.union (free_methods lam) !method_ids) meth_ids;
-    (* prerr_ids "meth_ids =" (Ident.Set.elements meth_ids);
-       prerr_ids "method_ids =" (Ident.Set.elements !method_ids); *)
-    let new_ids = List.fold_right Ident.Set.add new_ids !method_ids in
-    let fv = Ident.Set.inter fv new_ids in
-    new_ids' := !new_ids' @ Ident.Set.elements fv;
-    (* prerr_ids "new_ids' =" !new_ids'; *)
-    let i = ref (i0-1) in
-    List.fold_left
-      (fun subst id ->
-        incr i; Ident.Map.add id (lfield env !i)  subst)
-      Ident.Map.empty !new_ids'
-  in
-  let new_ids_meths = ref [] in
-  let no_env_update _ _ env = env in
-  let msubst arr = function
-      Lfunction {kind = Curried; params = (self, Pgenval) :: args; body} ->
-        let env = Ident.create_local "env" in
-        let body' =
-          if new_ids = [] then body else
-          Lambda.subst no_env_update (subst env body 0 new_ids_meths) body in
-        begin try
-          (* Doesn't seem to improve size for bytecode *)
-          (* if not !Clflags.native_code then raise Not_found; *)
-          if not arr || !Clflags.debug then raise Not_found;
-          builtin_meths [self] env env2 (lfunction args body')
-        with Not_found ->
-          [lfunction ((self, Pgenval) :: args)
-             (if not (Ident.Set.mem env (free_variables body')) then body' else
-              Llet(Alias, Pgenval, env,
-                   Lprim(Pfield_computed,
-                         [Lvar self; Lvar env2],
-                         Location.none),
-                   body'))]
-        end
-      | _ -> assert false
-  in
-  let new_ids_init = ref [] in
-  let env1 = Ident.create_local "env" and env1' = Ident.create_local "env'" in
-  let copy_env self =
-    if top then lambda_unit else
-    Lifused(env2, Lprim(Psetfield_computed (Pointer, Assignment),
-                        [Lvar self; Lvar env2; Lvar env1'],
-                        Location.none))
-  and subst_env envs l lam =
-    if top then lam else
-    (* must be called only once! *)
-    let lam = Lambda.subst no_env_update (subst env1 lam 1 new_ids_init) lam in
-    Llet(Alias, Pgenval, env1, (if l = [] then Lvar envs else lfield envs 0),
-    Llet(Alias, Pgenval, env1',
-         (if !new_ids_init = [] then Lvar env1 else lfield env1 0),
-         lam))
-  in
-
-  (* Now we start compiling the class *)
-  let cla = Ident.create_local "class" in
-  let (inh_init, obj_init) =
-    build_object_init_0 cla [] cl copy_env subst_env top ids in
-  let inh_init' = List.rev inh_init in
-  let (inh_init', cl_init) =
-    build_class_init cla true ([],[]) inh_init' obj_init msubst top cl
-  in
-  assert (inh_init' = []);
-  let table = Ident.create_local "table"
-  and class_init = Ident.create_local (Ident.name cl_id ^ "_init")
-  and env_init = Ident.create_local "env_init"
-  and obj_init = Ident.create_local "obj_init" in
-  let pub_meths =
-    List.sort
-      (fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
-      pub_meths in
-  let tags = List.map Btype.hash_variant pub_meths in
-  let rev_map = List.combine tags pub_meths in
-  List.iter2
-    (fun tag name ->
-      let name' = List.assoc tag rev_map in
-      if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
-    tags pub_meths;
-  let ltable table lam =
-    Llet(Strict, Pgenval, table,
-         mkappl (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
-  and ldirect obj_init =
-    Llet(Strict, Pgenval, obj_init, cl_init,
-         Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
-                   mkappl (Lvar obj_init, [lambda_unit])))
-  in
-  (* Simplest case: an object defined at toplevel (ids=[]) *)
-  if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
-
-  let concrete = (vflag = Concrete)
-  and lclass lam =
-    let cl_init = llets (Lfunction{kind = Curried;
-                                   attr = default_function_attribute;
-                                   loc = Location.none;
-                                   return = Pgenval;
-                                   params = [cla, Pgenval]; body = cl_init}) in
-    Llet(Strict, Pgenval, class_init, cl_init, lam (free_variables cl_init))
-  and lbody fv =
-    if List.for_all (fun id -> not (Ident.Set.mem id fv)) ids then
-      mkappl (oo_prim "make_class",[transl_meth_list pub_meths;
-                                    Lvar class_init])
-    else
-      ltable table (
-      Llet(
-      Strict, Pgenval, env_init, mkappl (Lvar class_init, [Lvar table]),
-      Lsequence(
-      mkappl (oo_prim "init_class", [Lvar table]),
-      Lprim(Pmakeblock(0, Immutable, None),
-            [mkappl (Lvar env_init, [lambda_unit]);
-             Lvar class_init; Lvar env_init; lambda_unit],
-            Location.none))))
-  and lbody_virt lenvs =
-    Lprim(Pmakeblock(0, Immutable, None),
-          [lambda_unit; Lfunction{kind = Curried;
-                                  attr = default_function_attribute;
-                                  loc = Location.none;
-                                  return = Pgenval;
-                                  params = [cla, Pgenval]; body = cl_init};
-           lambda_unit; lenvs],
-         Location.none)
-  in
-  (* Still easy: a class defined at toplevel *)
-  if top && concrete then lclass lbody else
-  if top then llets (lbody_virt lambda_unit) else
-
-  (* Now for the hard stuff: prepare for table caching *)
-  let envs = Ident.create_local "envs"
-  and cached = Ident.create_local "cached" in
-  let lenvs =
-    if !new_ids_meths = [] && !new_ids_init = [] && inh_init = []
-    then lambda_unit
-    else Lvar envs in
-  let lenv =
-    let menv =
-      if !new_ids_meths = [] then lambda_unit else
-      Lprim(Pmakeblock(0, Immutable, None),
-            List.map (fun id -> Lvar id) !new_ids_meths,
-            Location.none) in
-    if !new_ids_init = [] then menv else
-    Lprim(Pmakeblock(0, Immutable, None),
-          menv :: List.map (fun id -> Lvar id) !new_ids_init,
-          Location.none)
-  and linh_envs =
-    List.map
-      (fun (_, path_lam, _) -> Lprim(Pfield 3, [path_lam], Location.none))
-      (List.rev inh_init)
-  in
-  let make_envs lam =
-    Llet(StrictOpt, Pgenval, envs,
-         (if linh_envs = [] then lenv else
-         Lprim(Pmakeblock(0, Immutable, None),
-               lenv :: linh_envs, Location.none)),
-         lam)
-  and def_ids cla lam =
-    Llet(StrictOpt, Pgenval, env2,
-         mkappl (oo_prim "new_variable", [Lvar cla; transl_label ""]),
-         lam)
-  in
-  let inh_paths =
-    List.filter
-      (fun (path, _, _) -> List.mem (Path.head path) new_ids) inh_init
-  in
-  let inh_keys =
-    List.map
-      (fun (_, path_lam, _) -> Lprim(Pfield 1, [path_lam], Location.none))
-      inh_paths
-  in
-  let lclass lam =
-    Llet(Strict, Pgenval, class_init,
-         Lfunction{kind = Curried; params = [cla, Pgenval];
-                   return = Pgenval;
-                   attr = default_function_attribute;
-                   loc = Location.none;
-                   body = def_ids cla cl_init}, lam)
-  and lcache lam =
-    if inh_keys = [] then Llet(Alias, Pgenval, cached, Lvar tables, lam) else
-    Llet(Strict, Pgenval, cached,
-         mkappl (oo_prim "lookup_tables",
-                [Lvar tables; Lprim(Pmakeblock(0, Immutable, None),
-                                    inh_keys, Location.none)]),
-         lam)
-  and lset cached i lam =
-    Lprim(Psetfield(i, Pointer, Assignment),
-          [Lvar cached; lam], Location.none)
-  in
-  let ldirect () =
-    ltable cla
-      (Llet(Strict, Pgenval, env_init, def_ids cla cl_init,
-            Lsequence(mkappl (oo_prim "init_class", [Lvar cla]),
-                      lset cached 0 (Lvar env_init))))
-  and lclass_virt () =
-    lset cached 0
-      (Lfunction
-         {
-           kind = Curried;
-           attr = default_function_attribute;
-           loc = Location.none;
-           return = Pgenval;
-           params = [cla, Pgenval];
-           body = def_ids cla cl_init;
-         }
-      )
-  in
-  let lupdate_cache =
-    if ids = [] then ldirect () else
-      if not concrete then lclass_virt () else
-        lclass (
-            mkappl (oo_prim "make_class_store",
-                    [transl_meth_list pub_meths;
-                     Lvar class_init; Lvar cached])) in
-  let lcheck_cache =
-    if !Clflags.native_code && !Clflags.afl_instrument then
-      (* When afl-fuzz instrumentation is enabled, ignore the cache
-         so that the program's behaviour does not change between runs *)
-      lupdate_cache
-    else
-      Lifthenelse(lfield cached 0, lambda_unit, lupdate_cache) in
-  llets (
-  lcache (
-  Lsequence(lcheck_cache,
-  make_envs (
-  if ids = [] then mkappl (lfield cached 0, [lenvs]) else
-  Lprim(Pmakeblock(0, Immutable, None),
-        (if concrete then
-          [mkappl (lfield cached 0, [lenvs]);
-           lfield cached 1;
-           lfield cached 0;
-           lenvs]
-        else [lambda_unit; lfield cached 0; lambda_unit; lenvs]),
-        Location.none
-       )))))
-
-(* Wrapper for class compilation *)
-(*
-    let cl_id = ci.ci_id_class in
-(* TODO: cl_id is used somewhere else as typesharp ? *)
-  let _arity = List.length ci.ci_params in
-  let pub_meths = m in
-  let cl = ci.ci_expr in
-  let vflag = vf in
-*)
-
-let transl_class ids id pub_meths cl vf =
-  oo_wrap cl.cl_env false (transl_class ids id pub_meths cl) vf
-
-let () =
-  transl_object := (fun id meths cl -> transl_class [] id meths cl Concrete)
-
-(* Error report *)
-
-open Format
-
-let report_error ppf = function
-  | Tags (lab1, lab2) ->
-      fprintf ppf "Method labels `%s' and `%s' are incompatible.@ %s"
-        lab1 lab2 "Change one of them."
-
-let () =
-  Location.register_error_of_exn
-    (function
-      | Error (loc, err) ->
-        Some (Location.error_of_printer ~loc report_error err)
-      | _ ->
-        None
-    )
diff --git a/bytecomp/translclass.mli b/bytecomp/translclass.mli
deleted file mode 100644
index 4c4bed0f63..0000000000
--- a/bytecomp/translclass.mli
+++ /dev/null
@@ -1,29 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*          Jerome Vouillon, 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 Typedtree
-open Lambda
-
-val transl_class :
-  Ident.t list -> Ident.t ->
-  string list -> class_expr -> Asttypes.virtual_flag -> lambda;;
-
-type error = Tags of string * string
-
-exception Error of Location.t * error
-
-open Format
-
-val report_error: formatter -> error -> unit
diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml
deleted file mode 100644
index 6fe2dcbbb9..0000000000
--- a/bytecomp/translcore.ml
+++ /dev/null
@@ -1,1048 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 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.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Translation from typed abstract syntax to lambda terms,
-   for the core language *)
-
-open Misc
-open Asttypes
-open Primitive
-open Types
-open Typedtree
-open Typeopt
-open Lambda
-
-type error =
-    Free_super_var
-  | Unreachable_reached
-
-exception Error of Location.t * error
-
-let use_dup_for_constant_arrays_bigger_than = 4
-
-(* Forward declaration -- to be filled in by Translmod.transl_module *)
-let transl_module =
-  ref((fun _cc _rootpath _modl -> assert false) :
-      module_coercion -> Path.t option -> module_expr -> lambda)
-
-let transl_object =
-  ref (fun _id _s _cl -> assert false :
-       Ident.t -> string list -> class_expr -> lambda)
-
-(* Compile an exception/extension definition *)
-
-let prim_fresh_oo_id =
-  Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false)
-
-let transl_extension_constructor env path ext =
-  let path =
-    Printtyp.wrap_printing_env env ~error:true (fun () ->
-      Option.map (Printtyp.rewrite_double_underscore_paths env) path)
-  in
-  let name =
-    match path, !Clflags.for_package with
-      None, _ -> Ident.name ext.ext_id
-    | Some p, None -> Path.name p
-    | Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p)
-  in
-  let loc = ext.ext_loc in
-  match ext.ext_kind with
-    Text_decl _ ->
-      Lprim (Pmakeblock (Obj.object_tag, Immutable, None),
-        [Lconst (Const_base (Const_string (name, None)));
-         Lprim (prim_fresh_oo_id, [Lconst (Const_base (Const_int 0))], loc)],
-        loc)
-  | Text_rebind(path, _lid) ->
-      transl_extension_path loc env path
-
-(* To propagate structured constants *)
-
-exception Not_constant
-
-let extract_constant = function
-    Lconst sc -> sc
-  | _ -> raise Not_constant
-
-let extract_float = function
-    Const_base(Const_float f) -> f
-  | _ -> fatal_error "Translcore.extract_float"
-
-(* Push the default values under the functional abstractions *)
-(* Also push bindings of module patterns, since this sound *)
-
-type binding =
-  | Bind_value of value_binding list
-  | Bind_module of Ident.t * string loc * module_presence * module_expr
-
-let rec push_defaults loc bindings cases partial =
-  match cases with
-    [{c_lhs=pat; c_guard=None;
-      c_rhs={exp_desc = Texp_function { arg_label; param; cases; partial; } }
-        as exp}] ->
-      let cases = push_defaults exp.exp_loc bindings cases partial in
-      [{c_lhs=pat; c_guard=None;
-        c_rhs={exp with exp_desc = Texp_function { arg_label; param; cases;
-          partial; }}}]
-  | [{c_lhs=pat; c_guard=None;
-      c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#default"};_}];
-             exp_desc = Texp_let
-               (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2))}}] ->
-      push_defaults loc (Bind_value binds :: bindings)
-                   [{c_lhs=pat;c_guard=None;c_rhs=e2}]
-                   partial
-  | [{c_lhs=pat; c_guard=None;
-      c_rhs={exp_attributes=[{Parsetree.attr_name = {txt="#modulepat"};_}];
-             exp_desc = Texp_letmodule
-               (id, name, pres, mexpr,
-                ({exp_desc = Texp_function _} as e2))}}] ->
-      push_defaults loc (Bind_module (id, name, pres, mexpr) :: bindings)
-                   [{c_lhs=pat;c_guard=None;c_rhs=e2}]
-                   partial
-  | [case] ->
-      let exp =
-        List.fold_left
-          (fun exp binds ->
-            {exp with exp_desc =
-             match binds with
-             | Bind_value binds -> Texp_let(Nonrecursive, binds, exp)
-             | Bind_module (id, name, pres, mexpr) ->
-                 Texp_letmodule (id, name, pres, mexpr, exp)})
-          case.c_rhs bindings
-      in
-      [{case with c_rhs=exp}]
-  | {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] ->
-      let param = Typecore.name_cases "param" cases in
-      let desc =
-        {val_type = pat.pat_type; val_kind = Val_reg;
-         val_attributes = []; Types.val_loc = Location.none; }
-      in
-      let env = Env.add_value param desc exp.exp_env in
-      let name = Ident.name param in
-      let exp =
-        { exp with exp_loc = loc; exp_env = env; exp_desc =
-          Texp_match
-            ({exp with exp_type = pat.pat_type; exp_env = env; exp_desc =
-              Texp_ident
-                (Path.Pident param, mknoloc (Longident.Lident name), desc)},
-             cases, partial) }
-      in
-      push_defaults loc bindings
-        [{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)};
-          c_guard=None; c_rhs=exp}]
-        Total
-  | _ ->
-      cases
-
-(* Insertion of debugging events *)
-
-let event_before = Translprim.event_before
-
-let event_after = Translprim.event_after
-
-let event_function exp lam =
-  if !Clflags.debug && not !Clflags.native_code then
-    let repr = Some (ref 0) in
-    let (info, body) = lam repr in
-    (info,
-     Levent(body, {lev_loc = exp.exp_loc;
-                   lev_kind = Lev_function;
-                   lev_repr = repr;
-                   lev_env = exp.exp_env}))
-  else
-    lam None
-
-(* Assertions *)
-
-let assert_failed exp =
-  let slot =
-    transl_extension_path Location.none
-      Env.initial_safe_string Predef.path_assert_failure
-  in
-  let (fname, line, char) =
-    Location.get_pos_info exp.exp_loc.Location.loc_start
-  in
-  Lprim(Praise Raise_regular, [event_after exp
-    (Lprim(Pmakeblock(0, Immutable, None),
-          [slot;
-           Lconst(Const_block(0,
-              [Const_base(Const_string (fname, None));
-               Const_base(Const_int line);
-               Const_base(Const_int char)]))], exp.exp_loc))], exp.exp_loc)
-;;
-
-let rec cut n l =
-  if n = 0 then ([],l) else
-  match l with [] -> failwith "Translcore.cut"
-  | a::l -> let (l1,l2) = cut (n-1) l in (a::l1,l2)
-
-(* Translation of expressions *)
-
-let rec iter_exn_names f pat =
-  match pat.pat_desc with
-  | Tpat_var (id, _) -> f id
-  | Tpat_alias (p, id, _) ->
-      f id;
-      iter_exn_names f p
-  | _ -> ()
-
-let transl_ident loc env ty path desc =
-  match desc.val_kind with
-  | Val_prim p ->
-      Translprim.transl_primitive loc p env ty (Some path)
-  | Val_anc _ ->
-      raise(Error(loc, Free_super_var))
-  | Val_reg | Val_self _ ->
-      transl_value_path loc env path
-  |  _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
-
-let rec transl_exp e =
-  List.iter (Translattribute.check_attribute e) e.exp_attributes;
-  let eval_once =
-    (* Whether classes for immediate objects must be cached *)
-    match e.exp_desc with
-      Texp_function _ | Texp_for _ | Texp_while _ -> false
-    | _ -> true
-  in
-  if eval_once then transl_exp0 e else
-  Translobj.oo_wrap e.exp_env true transl_exp0 e
-
-and transl_exp0 e =
-  match e.exp_desc with
-  | Texp_ident(path, _, desc) ->
-      transl_ident e.exp_loc e.exp_env e.exp_type path desc
-  | Texp_constant cst ->
-      Lconst(Const_base cst)
-  | Texp_let(rec_flag, pat_expr_list, body) ->
-      transl_let rec_flag pat_expr_list (event_before body (transl_exp body))
-  | Texp_function { arg_label = _; param; cases; partial; } ->
-      let ((kind, params, return), body) =
-        event_function e
-          (function repr ->
-            let pl = push_defaults e.exp_loc [] cases partial in
-            let return_kind = function_return_value_kind e.exp_env e.exp_type in
-            transl_function e.exp_loc return_kind !Clflags.native_code repr
-              partial param pl)
-      in
-      let attr = default_function_attribute in
-      let loc = e.exp_loc in
-      let lam = Lfunction{kind; params; return; body; attr; loc} in
-      Translattribute.add_function_attributes lam loc e.exp_attributes
-  | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p});
-                exp_type = prim_type } as funct, oargs)
-    when List.length oargs >= p.prim_arity
-    && List.for_all (fun (_, arg) -> arg <> None) oargs ->
-      let argl, extra_args = cut p.prim_arity oargs in
-      let arg_exps =
-         List.map (function _, Some x -> x | _ -> assert false) argl
-      in
-      let args = transl_list arg_exps in
-      let prim_exp = if extra_args = [] then Some e else None in
-      let lam =
-        Translprim.transl_primitive_application
-          e.exp_loc p e.exp_env prim_type path
-          prim_exp args arg_exps
-      in
-      if extra_args = [] then lam
-      else begin
-        let should_be_tailcall, funct =
-          Translattribute.get_tailcall_attribute funct
-        in
-        let inlined, funct =
-          Translattribute.get_and_remove_inlined_attribute funct
-        in
-        let specialised, funct =
-          Translattribute.get_and_remove_specialised_attribute funct
-        in
-        let e = { e with exp_desc = Texp_apply(funct, oargs) } in
-        event_after e
-          (transl_apply ~should_be_tailcall ~inlined ~specialised
-             lam extra_args e.exp_loc)
-      end
-  | Texp_apply(funct, oargs) ->
-      let should_be_tailcall, funct =
-        Translattribute.get_tailcall_attribute funct
-      in
-      let inlined, funct =
-        Translattribute.get_and_remove_inlined_attribute funct
-      in
-      let specialised, funct =
-        Translattribute.get_and_remove_specialised_attribute funct
-      in
-      let e = { e with exp_desc = Texp_apply(funct, oargs) } in
-      event_after e
-        (transl_apply ~should_be_tailcall ~inlined ~specialised
-           (transl_exp funct) oargs e.exp_loc)
-  | Texp_match(arg, pat_expr_list, partial) ->
-      transl_match e arg pat_expr_list partial
-  | Texp_try(body, pat_expr_list) ->
-      let id = Typecore.name_cases "exn" pat_expr_list in
-      Ltrywith(transl_exp body, id,
-               Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list))
-  | Texp_tuple el ->
-      let ll, shape = transl_list_with_shape el in
-      begin try
-        Lconst(Const_block(0, List.map extract_constant ll))
-      with Not_constant ->
-        Lprim(Pmakeblock(0, Immutable, Some shape), ll, e.exp_loc)
-      end
-  | Texp_construct(_, cstr, args) ->
-      let ll, shape = transl_list_with_shape args in
-      if cstr.cstr_inlined <> None then begin match ll with
-        | [x] -> x
-        | _ -> assert false
-      end else begin match cstr.cstr_tag with
-        Cstr_constant n ->
-          Lconst(Const_pointer n)
-      | Cstr_unboxed ->
-          (match ll with [v] -> v | _ -> assert false)
-      | Cstr_block n ->
-          begin try
-            Lconst(Const_block(n, List.map extract_constant ll))
-          with Not_constant ->
-            Lprim(Pmakeblock(n, Immutable, Some shape), ll, e.exp_loc)
-          end
-      | Cstr_extension(path, is_const) ->
-          let lam = transl_extension_path e.exp_loc e.exp_env path in
-          if is_const then lam
-          else
-            Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)),
-                  lam :: ll, e.exp_loc)
-      end
-  | Texp_extension_constructor (_, path) ->
-      transl_extension_path e.exp_loc e.exp_env path
-  | Texp_variant(l, arg) ->
-      let tag = Btype.hash_variant l in
-      begin match arg with
-        None -> Lconst(Const_pointer tag)
-      | Some arg ->
-          let lam = transl_exp arg in
-          try
-            Lconst(Const_block(0, [Const_base(Const_int tag);
-                                   extract_constant lam]))
-          with Not_constant ->
-            Lprim(Pmakeblock(0, Immutable, None),
-                  [Lconst(Const_base(Const_int tag)); lam], e.exp_loc)
-      end
-  | Texp_record {fields; representation; extended_expression} ->
-      transl_record e.exp_loc e.exp_env fields representation
-        extended_expression
-  | Texp_field(arg, _, lbl) ->
-      let targ = transl_exp arg in
-      begin match lbl.lbl_repres with
-          Record_regular | Record_inlined _ ->
-          Lprim (Pfield lbl.lbl_pos, [targ], e.exp_loc)
-        | Record_unboxed _ -> targ
-        | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [targ], e.exp_loc)
-        | Record_extension _ ->
-          Lprim (Pfield (lbl.lbl_pos + 1), [targ], e.exp_loc)
-      end
-  | Texp_setfield(arg, _, lbl, newval) ->
-      let access =
-        match lbl.lbl_repres with
-          Record_regular
-        | Record_inlined _ ->
-          Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment)
-        | Record_unboxed _ -> assert false
-        | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)
-        | Record_extension _ ->
-          Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment)
-      in
-      Lprim(access, [transl_exp arg; transl_exp newval], e.exp_loc)
-  | Texp_array expr_list ->
-      let kind = array_kind e in
-      let ll = transl_list expr_list in
-      begin try
-        (* For native code the decision as to which compilation strategy to
-           use is made later.  This enables the Flambda passes to lift certain
-           kinds of array definitions to symbols. *)
-        (* Deactivate constant optimization if array is small enough *)
-        if List.length ll <= use_dup_for_constant_arrays_bigger_than
-        then begin
-          raise Not_constant
-        end;
-        begin match List.map extract_constant ll with
-        | exception Not_constant when kind = Pfloatarray ->
-            (* We cannot currently lift [Pintarray] arrays safely in Flambda
-               because [caml_modify] might be called upon them (e.g. from
-               code operating on polymorphic arrays, or functions such as
-               [caml_array_blit].
-               To avoid having different Lambda code for
-               bytecode/Closure vs.  Flambda, we always generate
-               [Pduparray] here, and deal with it in [Bytegen] (or in
-               the case of Closure, in [Cmmgen], which already has to
-               handle [Pduparray Pmakearray Pfloatarray] in the case
-               where the array turned out to be inconstant).
-               When not [Pfloatarray], the exception propagates to the handler
-               below. *)
-            let imm_array =
-              Lprim (Pmakearray (kind, Immutable), ll, e.exp_loc)
-            in
-            Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc)
-        | cl ->
-            let imm_array =
-              match kind with
-              | Paddrarray | Pintarray ->
-                  Lconst(Const_block(0, cl))
-              | Pfloatarray ->
-                  Lconst(Const_float_array(List.map extract_float cl))
-              | Pgenarray ->
-                  raise Not_constant    (* can this really happen? *)
-            in
-            Lprim (Pduparray (kind, Mutable), [imm_array], e.exp_loc)
-        end
-      with Not_constant ->
-        Lprim(Pmakearray (kind, Mutable), ll, e.exp_loc)
-      end
-  | Texp_ifthenelse(cond, ifso, Some ifnot) ->
-      Lifthenelse(transl_exp cond,
-                  event_before ifso (transl_exp ifso),
-                  event_before ifnot (transl_exp ifnot))
-  | Texp_ifthenelse(cond, ifso, None) ->
-      Lifthenelse(transl_exp cond,
-                  event_before ifso (transl_exp ifso),
-                  lambda_unit)
-  | Texp_sequence(expr1, expr2) ->
-      Lsequence(transl_exp expr1, event_before expr2 (transl_exp expr2))
-  | Texp_while(cond, body) ->
-      Lwhile(transl_exp cond, event_before body (transl_exp body))
-  | Texp_for(param, _, low, high, dir, body) ->
-      Lfor(param, transl_exp low, transl_exp high, dir,
-           event_before body (transl_exp body))
-  | Texp_send(_, _, Some exp) -> transl_exp exp
-  | Texp_send(expr, met, None) ->
-      let obj = transl_exp expr in
-      let lam =
-        match met with
-          Tmeth_val id -> Lsend (Self, Lvar id, obj, [], e.exp_loc)
-        | Tmeth_name nm ->
-            let (tag, cache) = Translobj.meth obj nm in
-            let kind = if cache = [] then Public else Cached in
-            Lsend (kind, tag, obj, cache, e.exp_loc)
-      in
-      event_after e lam
-  | Texp_new (cl, {Location.loc=loc}, _) ->
-      Lapply{ap_should_be_tailcall=false;
-             ap_loc=loc;
-             ap_func=
-               Lprim(Pfield 0, [transl_class_path loc e.exp_env cl], loc);
-             ap_args=[lambda_unit];
-             ap_inlined=Default_inline;
-             ap_specialised=Default_specialise}
-  | Texp_instvar(path_self, path, _) ->
-      let self = transl_value_path e.exp_loc e.exp_env path_self in
-      let var = transl_value_path e.exp_loc e.exp_env path in
-      Lprim(Pfield_computed, [self; var], e.exp_loc)
-  | Texp_setinstvar(path_self, path, _, expr) ->
-      let self = transl_value_path e.exp_loc e.exp_env path_self in
-      let var = transl_value_path e.exp_loc e.exp_env path in
-      transl_setinstvar e.exp_loc self var expr
-  | Texp_override(path_self, modifs) ->
-      let self = transl_value_path e.exp_loc e.exp_env path_self in
-      let cpy = Ident.create_local "copy" in
-      Llet(Strict, Pgenval, cpy,
-           Lapply{ap_should_be_tailcall=false;
-                  ap_loc=Location.none;
-                  ap_func=Translobj.oo_prim "copy";
-                  ap_args=[self];
-                  ap_inlined=Default_inline;
-                  ap_specialised=Default_specialise},
-           List.fold_right
-             (fun (path, _, expr) rem ->
-               let var = transl_value_path e.exp_loc e.exp_env path in
-                Lsequence(transl_setinstvar Location.none
-                            (Lvar cpy) var expr, rem))
-             modifs
-             (Lvar cpy))
-  | Texp_letmodule(id, loc, Mp_present, modl, body) ->
-      let defining_expr =
-        Levent (!transl_module Tcoerce_none None modl, {
-          lev_loc = loc.loc;
-          lev_kind = Lev_module_definition id;
-          lev_repr = None;
-          lev_env = Env.empty;
-        })
-      in
-      Llet(Strict, Pgenval, id, defining_expr, transl_exp body)
-  | Texp_letmodule(_, _, Mp_absent, _, body) ->
-      transl_exp body
-  | Texp_letexception(cd, body) ->
-      Llet(Strict, Pgenval,
-           cd.ext_id, transl_extension_constructor e.exp_env None cd,
-           transl_exp body)
-  | Texp_pack modl ->
-      !transl_module Tcoerce_none None modl
-  | Texp_assert {exp_desc=Texp_construct(_, {cstr_name="false"}, _)} ->
-      assert_failed e
-  | Texp_assert (cond) ->
-      if !Clflags.noassert
-      then lambda_unit
-      else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e)
-  | Texp_lazy e ->
-      (* when e needs no computation (constants, identifiers, ...), we
-         optimize the translation just as Lazy.lazy_from_val would
-         do *)
-      begin match Typeopt.classify_lazy_argument e with
-      | `Constant_or_function ->
-        (* A constant expr (of type <> float if [Config.flat_float_array] is
-           true) gets compiled as itself. *)
-         transl_exp e
-      | `Float_that_cannot_be_shortcut ->
-          (* We don't need to wrap with Popaque: this forward
-             block will never be shortcutted since it points to a float
-             and Config.flat_float_array is true. *)
-          Lprim(Pmakeblock(Obj.forward_tag, Immutable, None),
-                [transl_exp e], e.exp_loc)
-      | `Identifier `Forward_value ->
-         (* CR-someday mshinwell: Consider adding a new primitive
-            that expresses the construction of forward_tag blocks.
-            We need to use [Popaque] here to prevent unsound
-            optimisation in Flambda, but the concept of a mutable
-            block doesn't really match what is going on here.  This
-            value may subsequently turn into an immediate... *)
-         Lprim (Popaque,
-                [Lprim(Pmakeblock(Obj.forward_tag, Immutable, None),
-                       [transl_exp e], e.exp_loc)],
-                e.exp_loc)
-      | `Identifier `Other ->
-         transl_exp e
-      | `Other ->
-         (* other cases compile to a lazy block holding a function *)
-         let fn = Lfunction {kind = Curried;
-                             params= [Ident.create_local "param", Pgenval];
-                             return = Pgenval;
-                             attr = default_function_attribute;
-                             loc = e.exp_loc;
-                             body = transl_exp e} in
-          Lprim(Pmakeblock(Config.lazy_tag, Mutable, None), [fn], e.exp_loc)
-      end
-  | Texp_object (cs, meths) ->
-      let cty = cs.cstr_type in
-      let cl = Ident.create_local "class" in
-      !transl_object cl meths
-        { cl_desc = Tcl_structure cs;
-          cl_loc = e.exp_loc;
-          cl_type = Cty_signature cty;
-          cl_env = e.exp_env;
-          cl_attributes = [];
-         }
-  | Texp_letop{let_; ands; param; body; partial} ->
-      event_after e
-        (transl_letop e.exp_loc e.exp_env let_ ands param body partial)
-  | Texp_unreachable ->
-      raise (Error (e.exp_loc, Unreachable_reached))
-  | Texp_open (od, e) ->
-      let pure = pure_module od.open_expr in
-      (* this optimization shouldn't be needed because Simplif would
-          actually remove the [Llet] when it's not used.
-          But since [scan_used_globals] runs before Simplif, we need to
-          do it. *)
-      begin match od.open_bound_items with
-      | [] when pure = Alias -> transl_exp e
-      | _ ->
-          let oid = Ident.create_local "open" in
-          let body, _ =
-            List.fold_left (fun (body, pos) id ->
-              Llet(Alias, Pgenval, id,
-                   Lprim(Pfield pos, [Lvar oid], od.open_loc), body),
-              pos + 1
-            ) (transl_exp e, 0) (bound_value_identifiers od.open_bound_items)
-          in
-          Llet(pure, Pgenval, oid,
-               !transl_module Tcoerce_none None od.open_expr, body)
-      end
-
-and pure_module m =
-  match m.mod_desc with
-    Tmod_ident _ -> Alias
-  | Tmod_constraint (m,_,_,_) -> pure_module m
-  | _ -> Strict
-
-and transl_list expr_list =
-  List.map transl_exp expr_list
-
-and transl_list_with_shape expr_list =
-  let transl_with_shape e =
-    let shape = Typeopt.value_kind e.exp_env e.exp_type in
-    transl_exp e, shape
-  in
-  List.split (List.map transl_with_shape expr_list)
-
-and transl_guard guard rhs =
-  let expr = event_before rhs (transl_exp rhs) in
-  match guard with
-  | None -> expr
-  | Some cond ->
-      event_before cond (Lifthenelse(transl_exp cond, expr, staticfail))
-
-and transl_case {c_lhs; c_guard; c_rhs} =
-  c_lhs, transl_guard c_guard c_rhs
-
-and transl_cases cases =
-  let cases =
-    List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in
-  List.map transl_case cases
-
-and transl_case_try {c_lhs; c_guard; c_rhs} =
-  iter_exn_names Translprim.add_exception_ident c_lhs;
-  Misc.try_finally
-    (fun () -> c_lhs, transl_guard c_guard c_rhs)
-    ~always:(fun () ->
-        iter_exn_names Translprim.remove_exception_ident c_lhs)
-
-and transl_cases_try cases =
-  let cases =
-    List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in
-  List.map transl_case_try cases
-
-and transl_tupled_cases patl_expr_list =
-  let patl_expr_list =
-    List.filter (fun (_,_,e) -> e.exp_desc <> Texp_unreachable)
-      patl_expr_list in
-  List.map (fun (patl, guard, expr) -> (patl, transl_guard guard expr))
-    patl_expr_list
-
-and transl_apply ?(should_be_tailcall=false) ?(inlined = Default_inline)
-      ?(specialised = Default_specialise) lam sargs loc =
-  let lapply funct args =
-    match funct with
-      Lsend(k, lmet, lobj, largs, loc) ->
-        Lsend(k, lmet, lobj, largs @ args, loc)
-    | Levent(Lsend(k, lmet, lobj, largs, loc), _) ->
-        Lsend(k, lmet, lobj, largs @ args, loc)
-    | Lapply ap ->
-        Lapply {ap with ap_args = ap.ap_args @ args; ap_loc = loc}
-    | lexp ->
-        Lapply {ap_should_be_tailcall=should_be_tailcall;
-                ap_loc=loc;
-                ap_func=lexp;
-                ap_args=args;
-                ap_inlined=inlined;
-                ap_specialised=specialised;}
-  in
-  let rec build_apply lam args = function
-      (None, optional) :: l ->
-        let defs = ref [] in
-        let protect name lam =
-          match lam with
-            Lvar _ | Lconst _ -> lam
-          | _ ->
-              let id = Ident.create_local name in
-              defs := (id, lam) :: !defs;
-              Lvar id
-        in
-        let args, args' =
-          if List.for_all (fun (_,opt) -> opt) args then [], args
-          else args, [] in
-        let lam =
-          if args = [] then lam else lapply lam (List.rev_map fst args) in
-        let handle = protect "func" lam
-        and l = List.map (fun (arg, opt) -> may_map (protect "arg") arg, opt) l
-        and id_arg = Ident.create_local "param" in
-        let body =
-          match build_apply handle ((Lvar id_arg, optional)::args') l with
-            Lfunction{kind = Curried; params = ids; return;
-                      body = lam; attr; loc} ->
-              Lfunction{kind = Curried;
-                        params = (id_arg, Pgenval)::ids;
-                        return;
-                        body = lam; attr;
-                        loc}
-          | Levent(Lfunction{kind = Curried; params = ids; return;
-                             body = lam; attr; loc}, _) ->
-              Lfunction{kind = Curried; params = (id_arg, Pgenval)::ids;
-                        return;
-                        body = lam; attr;
-                        loc}
-          | lam ->
-              Lfunction{kind = Curried; params = [id_arg, Pgenval];
-                        return = Pgenval; body = lam;
-                        attr = default_stub_attribute; loc = loc}
-        in
-        List.fold_left
-          (fun body (id, lam) -> Llet(Strict, Pgenval, id, lam, body))
-          body !defs
-    | (Some arg, optional) :: l ->
-        build_apply lam ((arg, optional) :: args) l
-    | [] ->
-        lapply lam (List.rev_map fst args)
-  in
-  (build_apply lam [] (List.map (fun (l, x) ->
-                                   may_map transl_exp x, Btype.is_optional l)
-                                sargs)
-     : Lambda.lambda)
-
-and transl_function loc return untuplify_fn repr partial (param:Ident.t) cases =
-  match cases with
-    [{c_lhs=pat; c_guard=None;
-      c_rhs={exp_desc = Texp_function { arg_label = _; param = param'; cases;
-        partial = partial'; }; exp_env; exp_type} as exp}]
-    when Parmatch.inactive ~partial pat ->
-      let kind = value_kind pat.pat_env pat.pat_type in
-      let return_kind = function_return_value_kind exp_env exp_type in
-      let ((_, params, return), body) =
-        transl_function exp.exp_loc return_kind false repr partial' param' cases
-      in
-      ((Curried, (param, kind) :: params, return),
-       Matching.for_function loc None (Lvar param) [pat, body] partial)
-  | {c_lhs={pat_desc = Tpat_tuple pl}} :: _ when untuplify_fn ->
-      begin try
-        let size = List.length pl in
-        let pats_expr_list =
-          List.map
-            (fun {c_lhs; c_guard; c_rhs} ->
-              (Matching.flatten_pattern size c_lhs, c_guard, c_rhs))
-            cases in
-        let kinds =
-          (* All the patterns might not share the same types. We must take the
-             union of the patterns types *)
-          match pats_expr_list with
-          | [] -> assert false
-          | (pats, _, _) :: cases ->
-              let first_case_kinds =
-                List.map (fun pat -> value_kind pat.pat_env pat.pat_type) pats
-              in
-              List.fold_left
-                (fun kinds (pats, _, _) ->
-                   List.map2 (fun kind pat ->
-                       value_kind_union kind
-                         (value_kind pat.pat_env pat.pat_type))
-                     kinds pats)
-                first_case_kinds cases
-        in
-        let tparams =
-          List.map (fun kind -> Ident.create_local "param", kind) kinds
-        in
-        let params = List.map fst tparams in
-        ((Tupled, tparams, return),
-         Matching.for_tupled_function loc params
-           (transl_tupled_cases pats_expr_list) partial)
-      with Matching.Cannot_flatten ->
-        ((Curried, [param, Pgenval], return),
-         Matching.for_function loc repr (Lvar param)
-           (transl_cases cases) partial)
-      end
-  | {c_lhs=pat} :: other_cases ->
-      let kind =
-        (* All the patterns might not share the same types. We must take the
-           union of the patterns types *)
-        List.fold_left (fun k {c_lhs=pat} ->
-            Typeopt.value_kind_union k
-              (value_kind pat.pat_env pat.pat_type))
-          (value_kind pat.pat_env pat.pat_type) other_cases
-      in
-      ((Curried, [param, kind], return),
-       Matching.for_function loc repr (Lvar param)
-         (transl_cases cases) partial)
-  | [] ->
-      (* With Camlp4, a pattern matching might be empty *)
-      ((Curried, [param, Pgenval], return),
-       Matching.for_function loc repr (Lvar param)
-         (transl_cases cases) partial)
-
-(*
-  Notice: transl_let consumes (ie compiles) its pat_expr_list argument,
-  and returns a function that will take the body of the lambda-let construct.
-  This complication allows choosing any compilation order for the
-  bindings and body of let constructs.
-*)
-and transl_let rec_flag pat_expr_list =
-  match rec_flag with
-    Nonrecursive ->
-      let rec transl = function
-        [] ->
-          fun body -> body
-      | {vb_pat=pat; vb_expr=expr; vb_attributes=attr; vb_loc} :: rem ->
-          let lam = transl_exp expr in
-          let lam = Translattribute.add_function_attributes lam vb_loc attr in
-          let mk_body = transl rem in
-          fun body -> Matching.for_let pat.pat_loc lam pat (mk_body body)
-      in transl pat_expr_list
-  | Recursive ->
-      let idlist =
-        List.map
-          (fun {vb_pat=pat} -> match pat.pat_desc with
-              Tpat_var (id,_) -> id
-            | Tpat_alias ({pat_desc=Tpat_any}, id,_) -> id
-            | _ -> assert false)
-        pat_expr_list in
-      let transl_case {vb_expr=expr; vb_attributes; vb_loc} id =
-        let lam = transl_exp expr in
-        let lam =
-          Translattribute.add_function_attributes lam vb_loc vb_attributes
-        in
-        (id, lam) in
-      let lam_bds = List.map2 transl_case pat_expr_list idlist in
-      fun body -> Lletrec(lam_bds, body)
-
-and transl_setinstvar loc self var expr =
-  Lprim(Psetfield_computed (maybe_pointer expr, Assignment),
-    [self; var; transl_exp expr], loc)
-
-and transl_record loc env fields repres opt_init_expr =
-  let size = Array.length fields in
-  (* Determine if there are "enough" fields (only relevant if this is a
-     functional-style record update *)
-  let no_init = match opt_init_expr with None -> true | _ -> false in
-  if no_init || size < Config.max_young_wosize
-  then begin
-    (* Allocate new record with given fields (and remaining fields
-       taken from init_expr if any *)
-    let init_id = Ident.create_local "init" in
-    let lv =
-      Array.mapi
-        (fun i (_, definition) ->
-           match definition with
-           | Kept typ ->
-               let field_kind = value_kind env typ in
-               let access =
-                 match repres with
-                   Record_regular | Record_inlined _ -> Pfield i
-                 | Record_unboxed _ -> assert false
-                 | Record_extension _ -> Pfield (i + 1)
-                 | Record_float -> Pfloatfield i in
-               Lprim(access, [Lvar init_id], loc), field_kind
-           | Overridden (_lid, expr) ->
-               let field_kind = value_kind expr.exp_env expr.exp_type in
-               transl_exp expr, field_kind)
-        fields
-    in
-    let ll, shape = List.split (Array.to_list lv) in
-    let mut =
-      if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields
-      then Mutable
-      else Immutable in
-    let lam =
-      try
-        if mut = Mutable then raise Not_constant;
-        let cl = List.map extract_constant ll in
-        match repres with
-        | Record_regular -> Lconst(Const_block(0, cl))
-        | Record_inlined tag -> Lconst(Const_block(tag, cl))
-        | Record_unboxed _ -> Lconst(match cl with [v] -> v | _ -> assert false)
-        | Record_float ->
-            Lconst(Const_float_array(List.map extract_float cl))
-        | Record_extension _ ->
-            raise Not_constant
-      with Not_constant ->
-        match repres with
-          Record_regular ->
-            Lprim(Pmakeblock(0, mut, Some shape), ll, loc)
-        | Record_inlined tag ->
-            Lprim(Pmakeblock(tag, mut, Some shape), ll, loc)
-        | Record_unboxed _ -> (match ll with [v] -> v | _ -> assert false)
-        | Record_float ->
-            Lprim(Pmakearray (Pfloatarray, mut), ll, loc)
-        | Record_extension path ->
-            let slot = transl_extension_path loc env path in
-            Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc)
-    in
-    begin match opt_init_expr with
-      None -> lam
-    | Some init_expr -> Llet(Strict, Pgenval, init_id,
-                             transl_exp init_expr, lam)
-    end
-  end else begin
-    (* Take a shallow copy of the init record, then mutate the fields
-       of the copy *)
-    let copy_id = Ident.create_local "newrecord" in
-    let update_field cont (lbl, definition) =
-      match definition with
-      | Kept _type -> cont
-      | Overridden (_lid, expr) ->
-          let upd =
-            match repres with
-              Record_regular
-            | Record_inlined _ ->
-                Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment)
-            | Record_unboxed _ -> assert false
-            | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)
-            | Record_extension _ ->
-                Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment)
-          in
-          Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr], loc), cont)
-    in
-    begin match opt_init_expr with
-      None -> assert false
-    | Some init_expr ->
-        Llet(Strict, Pgenval, copy_id,
-             Lprim(Pduprecord (repres, size), [transl_exp init_expr], loc),
-             Array.fold_left update_field (Lvar copy_id) fields)
-    end
-  end
-
-and transl_match e arg pat_expr_list partial =
-  let rewrite_case (val_cases, exn_cases, static_handlers as acc)
-        ({ c_lhs; c_guard; c_rhs } as case) =
-    if c_rhs.exp_desc = Texp_unreachable then acc else
-    let val_pat, exn_pat = split_pattern c_lhs in
-    match val_pat, exn_pat with
-    | None, None -> assert false
-    | Some pv, None ->
-        let val_case =
-          transl_case { case with c_lhs = pv }
-        in
-        val_case :: val_cases, exn_cases, static_handlers
-    | None, Some pe ->
-        let exn_case = transl_case_try { case with c_lhs = pe } in
-        val_cases, exn_case :: exn_cases, static_handlers
-    | Some pv, Some pe ->
-        assert (c_guard = None);
-        let lbl  = next_raise_count () in
-        let static_raise ids =
-          Lstaticraise (lbl, List.map (fun id -> Lvar id) ids)
-        in
-        (* Simplif doesn't like it if binders are not uniq, so we make sure to
-           use different names in the value and the exception branches. *)
-        let ids_full = Typedtree.pat_bound_idents_full pv in
-        let ids = List.map (fun (id, _, _) -> id) ids_full in
-        let ids_kinds =
-          List.map (fun (id, _, ty) -> id, Typeopt.value_kind pv.pat_env ty)
-            ids_full
-        in
-        let vids = List.map Ident.rename ids in
-        let pv = alpha_pat (List.combine ids vids) pv in
-        (* Also register the names of the exception so Re-raise happens. *)
-        iter_exn_names Translprim.add_exception_ident pe;
-        let rhs =
-          Misc.try_finally
-            (fun () -> event_before c_rhs (transl_exp c_rhs))
-            ~always:(fun () ->
-                iter_exn_names Translprim.remove_exception_ident pe)
-        in
-        (pv, static_raise vids) :: val_cases,
-        (pe, static_raise ids) :: exn_cases,
-        (lbl, ids_kinds, rhs) :: static_handlers
-  in
-  let val_cases, exn_cases, static_handlers =
-    let x, y, z = List.fold_left rewrite_case ([], [], []) pat_expr_list in
-    List.rev x, List.rev y, List.rev z
-  in
-  let static_catch body val_ids handler =
-    let id = Typecore.name_pattern "exn" (List.map fst exn_cases) in
-    let static_exception_id = next_raise_count () in
-    Lstaticcatch
-      (Ltrywith (Lstaticraise (static_exception_id, body), id,
-                 Matching.for_trywith (Lvar id) exn_cases),
-       (static_exception_id, val_ids),
-       handler)
-  in
-  let classic =
-    match arg, exn_cases with
-    | {exp_desc = Texp_tuple argl}, [] ->
-      assert (static_handlers = []);
-      Matching.for_multiple_match e.exp_loc (transl_list argl) val_cases partial
-    | {exp_desc = Texp_tuple argl}, _ :: _ ->
-        let val_ids =
-          List.map
-            (fun arg ->
-               Typecore.name_pattern "val" [],
-               Typeopt.value_kind arg.exp_env arg.exp_type
-            )
-            argl
-        in
-        let lvars = List.map (fun (id, _) -> Lvar id) val_ids in
-        static_catch (transl_list argl) val_ids
-          (Matching.for_multiple_match e.exp_loc lvars val_cases partial)
-    | arg, [] ->
-      assert (static_handlers = []);
-      Matching.for_function e.exp_loc None (transl_exp arg) val_cases partial
-    | arg, _ :: _ ->
-        let val_id = Typecore.name_cases "val" pat_expr_list in
-        let k = Typeopt.value_kind arg.exp_env arg.exp_type in
-        static_catch [transl_exp arg] [val_id, k]
-          (Matching.for_function e.exp_loc None (Lvar val_id) val_cases partial)
-  in
-  List.fold_left (fun body (static_exception_id, val_ids, handler) ->
-    Lstaticcatch (body, (static_exception_id, val_ids), handler)
-  ) classic static_handlers
-
-and transl_letop loc env let_ ands param case partial =
-  let rec loop prev_lam = function
-    | [] -> prev_lam
-    | and_ :: rest ->
-        let left_id = Ident.create_local "left" in
-        let right_id = Ident.create_local "right" in
-        let op =
-          transl_ident and_.bop_op_name.loc env
-            and_.bop_op_type and_.bop_op_path and_.bop_op_val
-        in
-        let exp = transl_exp and_.bop_exp in
-        let lam =
-          bind Strict right_id exp
-            (Lapply{ap_should_be_tailcall = false;
-                    ap_loc = and_.bop_loc;
-                    ap_func = op;
-                    ap_args=[Lvar left_id; Lvar right_id];
-                    ap_inlined=Default_inline;
-                    ap_specialised=Default_specialise})
-        in
-        bind Strict left_id prev_lam (loop lam rest)
-  in
-  let op =
-    transl_ident let_.bop_op_name.loc env
-      let_.bop_op_type let_.bop_op_path let_.bop_op_val
-  in
-  let exp = loop (transl_exp let_.bop_exp) ands in
-  let func =
-    let return_kind = value_kind case.c_rhs.exp_env case.c_rhs.exp_type in
-    let (kind, params, return), body =
-      event_function case.c_rhs
-        (function repr ->
-           transl_function case.c_rhs.exp_loc return_kind
-             !Clflags.native_code repr partial param [case])
-    in
-    let attr = default_function_attribute in
-    let loc = case.c_rhs.exp_loc in
-    Lfunction{kind; params; return; body; attr; loc}
-  in
-  Lapply{ap_should_be_tailcall = false;
-         ap_loc = loc;
-         ap_func = op;
-         ap_args=[exp; func];
-         ap_inlined=Default_inline;
-         ap_specialised=Default_specialise}
-
-(* Wrapper for class compilation *)
-
-(*
-let transl_exp = transl_exp_wrap
-
-let transl_let rec_flag pat_expr_list body =
-  match pat_expr_list with
-    [] -> body
-  | (_, expr) :: _ ->
-      Translobj.oo_wrap expr.exp_env false
-        (transl_let rec_flag pat_expr_list) body
-*)
-
-(* Error report *)
-
-open Format
-
-let report_error ppf = function
-  | Free_super_var ->
-      fprintf ppf
-        "Ancestor names can only be used to select inherited methods"
-  | Unreachable_reached ->
-      fprintf ppf "Unreachable expression was reached"
-
-let () =
-  Location.register_error_of_exn
-    (function
-      | Error (loc, err) ->
-          Some (Location.error_of_printer ~loc report_error err)
-      | _ ->
-        None
-    )
diff --git a/bytecomp/translcore.mli b/bytecomp/translcore.mli
deleted file mode 100644
index 7a27dbcb39..0000000000
--- a/bytecomp/translcore.mli
+++ /dev/null
@@ -1,50 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 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.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Translation from typed abstract syntax to lambda terms,
-   for the core language *)
-
-open Asttypes
-open Typedtree
-open Lambda
-
-val pure_module : module_expr -> let_kind
-
-val transl_exp: expression -> lambda
-val transl_apply: ?should_be_tailcall:bool
-                  -> ?inlined:inline_attribute
-                  -> ?specialised:specialise_attribute
-                  -> lambda -> (arg_label * expression option) list
-                  -> Location.t -> lambda
-val transl_let: rec_flag -> value_binding list -> lambda -> lambda
-
-val transl_extension_constructor: Env.t -> Path.t option ->
-  extension_constructor -> lambda
-
-type error =
-    Free_super_var
-  | Unreachable_reached
-
-exception Error of Location.t * error
-
-open Format
-
-val report_error: formatter -> error -> unit
-
-(* Forward declaration -- to be filled in by Translmod.transl_module *)
-val transl_module :
-      (module_coercion -> Path.t option -> module_expr -> lambda) ref
-val transl_object :
-      (Ident.t -> string list -> class_expr -> lambda) ref
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
deleted file mode 100644
index bf111693be..0000000000
--- a/bytecomp/translmod.ml
+++ /dev/null
@@ -1,1556 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 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.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Translation from typed abstract syntax to lambda terms,
-   for the module language *)
-
-open Misc
-open Asttypes
-open Path
-open Types
-open Typedtree
-open Lambda
-open Translobj
-open Translcore
-open Translclass
-
-type unsafe_component =
-  | Unsafe_module_binding
-  | Unsafe_functor
-  | Unsafe_non_function
-  | Unsafe_typext
-
-type unsafe_info = { reason:unsafe_component; loc:Location.t; subid:Ident.t }
-type error =
-  Circular_dependency of (Ident.t * unsafe_info) list
-| Conflicting_inline_attributes
-
-exception Error of Location.t * error
-
-(* Keep track of the root path (from the root of the namespace to the
-   currently compiled module expression).  Useful for naming extensions. *)
-
-let global_path glob = Some(Pident glob)
-let functor_path path param =
-  match path with
-    None -> None
-  | Some p -> Some(Papply(p, Pident param))
-let field_path path field =
-  match path with
-    None -> None
-  | Some p -> Some(Pdot(p, Ident.name field))
-
-(* Compile type extensions *)
-
-let transl_type_extension env rootpath tyext body =
-  List.fold_right
-    (fun ext body ->
-      let lam =
-        transl_extension_constructor env (field_path rootpath ext.ext_id) ext
-      in
-      Llet(Strict, Pgenval, ext.ext_id, lam, body))
-    tyext.tyext_constructors
-    body
-
-(* Compile a coercion *)
-
-let rec apply_coercion loc strict restr arg =
-  match restr with
-    Tcoerce_none ->
-      arg
-  | Tcoerce_structure(pos_cc_list, id_pos_list) ->
-      name_lambda strict arg (fun id ->
-        let get_field pos = Lprim(Pfield pos,[Lvar id], loc) in
-        let lam =
-          Lprim(Pmakeblock(0, Immutable, None),
-                List.map (apply_coercion_field loc get_field) pos_cc_list,
-                loc)
-        in
-        wrap_id_pos_list loc id_pos_list get_field lam)
-  | Tcoerce_functor(cc_arg, cc_res) ->
-      let param = Ident.create_local "funarg" in
-      let carg = apply_coercion loc Alias cc_arg (Lvar param) in
-      apply_coercion_result loc strict arg [param, Pgenval] [carg] cc_res
-  | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
-      Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None
-  | Tcoerce_alias (env, path, cc) ->
-      let lam = transl_module_path loc env path in
-      name_lambda strict arg
-        (fun _ -> apply_coercion loc Alias cc lam)
-
-and apply_coercion_field loc get_field (pos, cc) =
-  apply_coercion loc Alias cc (get_field pos)
-
-and apply_coercion_result loc strict funct params args cc_res =
-  match cc_res with
-  | Tcoerce_functor(cc_arg, cc_res) ->
-    let param = Ident.create_local "funarg" in
-    let arg = apply_coercion loc Alias cc_arg (Lvar param) in
-    apply_coercion_result loc strict funct
-      ((param, Pgenval) :: params) (arg :: args) cc_res
-  | _ ->
-      name_lambda strict funct
-        (fun id ->
-           Lfunction
-             {
-               kind = Curried;
-               params = List.rev params;
-               return = Pgenval;
-               attr = { default_function_attribute with
-                        is_a_functor = true;
-                        stub = true; };
-               loc = loc;
-               body = apply_coercion
-                   loc Strict cc_res
-                   (Lapply{ap_should_be_tailcall=false;
-                           ap_loc=loc;
-                           ap_func=Lvar id;
-                           ap_args=List.rev args;
-                           ap_inlined=Default_inline;
-                           ap_specialised=Default_specialise})})
-
-and wrap_id_pos_list loc id_pos_list get_field lam =
-  let fv = free_variables lam in
-  (*Format.eprintf "%a@." Printlambda.lambda lam;
-  Ident.Set.iter (fun id -> Format.eprintf "%a " Ident.print id) fv;
-  Format.eprintf "@.";*)
-  let (lam,s) =
-    List.fold_left (fun (lam, s) (id',pos,c) ->
-      if Ident.Set.mem id' fv then
-        let id'' = Ident.create_local (Ident.name id') in
-        (Llet(Alias, Pgenval, id'',
-             apply_coercion loc Alias c (get_field pos),lam),
-         Ident.Map.add id' id'' s)
-      else (lam, s))
-      (lam, Ident.Map.empty) id_pos_list
-  in
-  if s == Ident.Map.empty then lam else Lambda.rename s lam
-
-
-(* Compose two coercions
-   apply_coercion c1 (apply_coercion c2 e) behaves like
-   apply_coercion (compose_coercions c1 c2) e. *)
-
-let rec compose_coercions c1 c2 =
-  match (c1, c2) with
-    (Tcoerce_none, c2) -> c2
-  | (c1, Tcoerce_none) -> c1
-  | (Tcoerce_structure (pc1, ids1), Tcoerce_structure (pc2, ids2)) ->
-      let v2 = Array.of_list pc2 in
-      let ids1 =
-        List.map (fun (id,pos1,c1) ->
-          let (pos2,c2) = v2.(pos1) in (id, pos2, compose_coercions c1 c2))
-          ids1
-      in
-      Tcoerce_structure
-        (List.map
-           (fun pc ->
-              match pc with
-              | _, (Tcoerce_primitive _ | Tcoerce_alias _) ->
-                (* These cases do not take an argument (the position is -1),
-                   so they do not need adjusting. *)
-                pc
-              | (p1, c1) ->
-                let (p2, c2) = v2.(p1) in
-                (p2, compose_coercions c1 c2))
-          pc1,
-         ids1 @ ids2)
-  | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) ->
-      Tcoerce_functor(compose_coercions arg2 arg1,
-                      compose_coercions res1 res2)
-  | (c1, Tcoerce_alias (env, path, c2)) ->
-      Tcoerce_alias (env, path, compose_coercions c1 c2)
-  | (_, _) ->
-      fatal_error "Translmod.compose_coercions"
-
-(*
-let apply_coercion a b c =
-  Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b;
-  apply_coercion a b c
-
-let compose_coercions c1 c2 =
-  let c3 = compose_coercions c1 c2 in
-  let open Includemod in
-  Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@."
-    print_coercion c1 print_coercion c2 print_coercion c3;
-  c3
-*)
-
-(* Record the primitive declarations occurring in the module compiled *)
-
-let primitive_declarations = ref ([] : Primitive.description list)
-let record_primitive = function
-  | {val_kind=Val_prim p;val_loc} ->
-      Translprim.check_primitive_arity val_loc p;
-      primitive_declarations := p :: !primitive_declarations
-  | _ -> ()
-
-(* Utilities for compiling "module rec" definitions *)
-
-let mod_prim = Lambda.transl_prim "CamlinternalMod"
-
-let undefined_location loc =
-  let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
-  Lconst(Const_block(0,
-                     [Const_base(Const_string (fname, None));
-                      Const_base(Const_int line);
-                      Const_base(Const_int char)]))
-
-exception Initialization_failure of unsafe_info
-
-let init_shape id modl =
-  let rec init_shape_mod subid loc env mty =
-    match Mtype.scrape env mty with
-      Mty_ident _
-    | Mty_alias _ ->
-        raise (Initialization_failure {reason=Unsafe_module_binding;loc;subid})
-    | Mty_signature sg ->
-        Const_block(0, [Const_block(0, init_shape_struct env sg)])
-    | Mty_functor _ ->
-        (* can we do better? *)
-        raise (Initialization_failure {reason=Unsafe_functor;loc;subid})
-  and init_shape_struct env sg =
-    match sg with
-      [] -> []
-    | Sig_value(subid, {val_kind=Val_reg; val_type=ty; val_loc=loc},_) :: rem ->
-        let init_v =
-          match Ctype.expand_head env ty with
-            {desc = Tarrow(_,_,_,_)} ->
-              Const_pointer 0 (* camlinternalMod.Function *)
-          | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t ->
-              Const_pointer 1 (* camlinternalMod.Lazy *)
-          | _ ->
-              let not_a_function = {reason=Unsafe_non_function; loc; subid } in
-              raise (Initialization_failure not_a_function) in
-        init_v :: init_shape_struct env rem
-    | Sig_value(_, {val_kind=Val_prim _}, _) :: rem ->
-        init_shape_struct env rem
-    | Sig_value _ :: _rem ->
-        assert false
-    | Sig_type(id, tdecl, _, _) :: rem ->
-        init_shape_struct (Env.add_type ~check:false id tdecl env) rem
-    | Sig_typext (subid, {ext_loc=loc},_,_) :: _ ->
-        raise (Initialization_failure {reason=Unsafe_typext; loc; subid})
-    | Sig_module(id, Mp_present, md, _, _) :: rem ->
-        init_shape_mod id md.md_loc env md.md_type ::
-        init_shape_struct (Env.add_module_declaration ~check:false
-                             id Mp_present md env) rem
-    | Sig_module(id, Mp_absent, md, _, _) :: rem ->
-        init_shape_struct
-          (Env.add_module_declaration ~check:false
-                             id Mp_absent md env) rem
-    | Sig_modtype(id, minfo, _) :: rem ->
-        init_shape_struct (Env.add_modtype id minfo env) rem
-    | Sig_class _ :: rem ->
-        Const_pointer 2 (* camlinternalMod.Class *)
-        :: init_shape_struct env rem
-    | Sig_class_type _ :: rem ->
-        init_shape_struct env rem
-  in
-  try
-    Ok(undefined_location modl.mod_loc,
-       Lconst(init_shape_mod id modl.mod_loc modl.mod_env modl.mod_type))
-  with Initialization_failure reason -> Result.Error(reason)
-
-(* Reorder bindings to honor dependencies.  *)
-
-type binding_status =
-  | Undefined
-  | Inprogress of int option (** parent node *)
-  | Defined
-
-let extract_unsafe_cycle id status init cycle_start =
-  let info i = match init.(i) with
-    | Result.Error r -> id.(i), r
-    | Ok _ -> assert false in
-  let rec collect stop l i = match status.(i) with
-    | Inprogress None | Undefined | Defined -> assert false
-    | Inprogress Some i when i = stop -> info i :: l
-    | Inprogress Some i -> collect stop (info i::l) i in
-  collect cycle_start [] cycle_start
-
-let reorder_rec_bindings bindings =
-  let id = Array.of_list (List.map (fun (id,_,_,_) -> id) bindings)
-  and loc = Array.of_list (List.map (fun (_,loc,_,_) -> loc) bindings)
-  and init = Array.of_list (List.map (fun (_,_,init,_) -> init) bindings)
-  and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in
-  let fv = Array.map Lambda.free_variables rhs in
-  let num_bindings = Array.length id in
-  let status = Array.make num_bindings Undefined in
-  let res = ref [] in
-  let is_unsafe i = match init.(i) with
-    | Ok _ -> false
-    | Result.Error _ -> true in
-  let init_res i = match init.(i) with
-    | Result.Error _ -> None
-    | Ok(a,b) -> Some(a,b) in
-  let rec emit_binding parent i =
-    match status.(i) with
-      Defined -> ()
-    | Inprogress _ ->
-        status.(i) <- Inprogress parent;
-        let cycle = extract_unsafe_cycle id status init i in
-        raise(Error(loc.(i), Circular_dependency cycle))
-    | Undefined ->
-        if is_unsafe i then begin
-          status.(i) <- Inprogress parent;
-          for j = 0 to num_bindings - 1 do
-            if Ident.Set.mem id.(j) fv.(i) then emit_binding (Some i) j
-          done
-        end;
-        res := (id.(i), init_res i, rhs.(i)) :: !res;
-        status.(i) <- Defined in
-  for i = 0 to num_bindings - 1 do
-    match status.(i) with
-      Undefined -> emit_binding None i
-    | Inprogress _ -> assert false
-    | Defined -> ()
-  done;
-  List.rev !res
-
-(* Generate lambda-code for a reordered list of bindings *)
-
-let eval_rec_bindings bindings cont =
-  let rec bind_inits = function
-    [] ->
-      bind_strict bindings
-  | (_id, None, _rhs) :: rem ->
-      bind_inits rem
-  | (id, Some(loc, shape), _rhs) :: rem ->
-      Llet(Strict, Pgenval, id,
-           Lapply{ap_should_be_tailcall=false;
-                  ap_loc=Location.none;
-                  ap_func=mod_prim "init_mod";
-                  ap_args=[loc; shape];
-                  ap_inlined=Default_inline;
-                  ap_specialised=Default_specialise},
-           bind_inits rem)
-  and bind_strict = function
-    [] ->
-      patch_forwards bindings
-  | (id, None, rhs) :: rem ->
-      Llet(Strict, Pgenval, id, rhs, bind_strict rem)
-  | (_id, Some _, _rhs) :: rem ->
-      bind_strict rem
-  and patch_forwards = function
-    [] ->
-      cont
-  | (_id, None, _rhs) :: rem ->
-      patch_forwards rem
-  | (id, Some(_loc, shape), rhs) :: rem ->
-      Lsequence(Lapply{ap_should_be_tailcall=false;
-                       ap_loc=Location.none;
-                       ap_func=mod_prim "update_mod";
-                       ap_args=[shape; Lvar id; rhs];
-                       ap_inlined=Default_inline;
-                       ap_specialised=Default_specialise},
-                patch_forwards rem)
-  in
-    bind_inits bindings
-
-let compile_recmodule compile_rhs bindings cont =
-  eval_rec_bindings
-    (reorder_rec_bindings
-       (List.map
-          (fun {mb_id=id; mb_expr=modl; mb_loc=loc; _} ->
-            (id, modl.mod_loc, init_shape id modl, compile_rhs id modl loc))
-          bindings))
-    cont
-
-(* Code to translate class entries in a structure *)
-
-let transl_class_bindings cl_list =
-  let ids = List.map (fun (ci, _) -> ci.ci_id_class) cl_list in
-  (ids,
-   List.map
-     (fun ({ci_id_class=id; ci_expr=cl; ci_virt=vf}, meths) ->
-       (id, transl_class ids id meths cl vf))
-     cl_list)
-
-(* Compile one or more functors, merging curried functors to produce
-   multi-argument functors.  Any [@inline] attribute on a functor that is
-   merged must be consistent with any other [@inline] attribute(s) on the
-   functor(s) being merged with.  Such an attribute will be placed on the
-   resulting merged functor. *)
-
-let merge_inline_attributes attr1 attr2 loc =
-  match Lambda.merge_inline_attributes attr1 attr2 with
-  | Some attr -> attr
-  | None -> raise (Error (loc, Conflicting_inline_attributes))
-
-let merge_functors mexp coercion root_path =
-  let rec merge mexp coercion path acc inline_attribute =
-    let finished = acc, mexp, path, coercion, inline_attribute in
-    match mexp.mod_desc with
-    | Tmod_functor (param, _, _, body) ->
-      let inline_attribute' =
-        Translattribute.get_inline_attribute mexp.mod_attributes
-      in
-      let arg_coercion, res_coercion =
-        match coercion with
-        | Tcoerce_none -> Tcoerce_none, Tcoerce_none
-        | Tcoerce_functor (arg_coercion, res_coercion) ->
-          arg_coercion, res_coercion
-        | _ -> fatal_error "Translmod.merge_functors: bad coercion"
-      in
-      let loc = mexp.mod_loc in
-      let path = functor_path path param in
-      let inline_attribute =
-        merge_inline_attributes inline_attribute inline_attribute' loc
-      in
-      merge body res_coercion path ((param, loc, arg_coercion) :: acc)
-        inline_attribute
-    | _ -> finished
-  in
-  merge mexp coercion root_path [] Default_inline
-
-let rec compile_functor mexp coercion root_path loc =
-  let functor_params_rev, body, body_path, res_coercion, inline_attribute =
-    merge_functors mexp coercion root_path
-  in
-  assert (List.length functor_params_rev >= 1);  (* cf. [transl_module] *)
-  let params, body =
-    List.fold_left (fun (params, body) (param, loc, arg_coercion) ->
-        let param' = Ident.rename param in
-        let arg = apply_coercion loc Alias arg_coercion (Lvar param') in
-        let params = (param', Pgenval) :: params in
-        let body = Llet (Alias, Pgenval, param, arg, body) in
-        params, body)
-      ([], transl_module res_coercion body_path body)
-      functor_params_rev
-  in
-  Lfunction {
-    kind = Curried;
-    params;
-    return = Pgenval;
-    attr = {
-      inline = inline_attribute;
-      specialise = Default_specialise;
-      local = Default_local;
-      is_a_functor = true;
-      stub = false;
-    };
-    loc;
-    body;
-  }
-
-(* Compile a module expression *)
-
-and transl_module cc rootpath mexp =
-  List.iter (Translattribute.check_attribute_on_module mexp)
-    mexp.mod_attributes;
-  let loc = mexp.mod_loc in
-  match mexp.mod_desc with
-  | Tmod_ident (path,_) ->
-      apply_coercion loc Strict cc
-        (transl_module_path loc mexp.mod_env path)
-  | Tmod_structure str ->
-      fst (transl_struct loc [] cc rootpath str)
-  | Tmod_functor _ ->
-      oo_wrap mexp.mod_env true (fun () ->
-        compile_functor mexp cc rootpath loc) ()
-  | Tmod_apply(funct, arg, ccarg) ->
-      let inlined_attribute, funct =
-        Translattribute.get_and_remove_inlined_attribute_on_module funct
-      in
-      oo_wrap mexp.mod_env true
-        (apply_coercion loc Strict cc)
-        (Lapply{ap_should_be_tailcall=false;
-                ap_loc=loc;
-                ap_func=transl_module Tcoerce_none None funct;
-                ap_args=[transl_module ccarg None arg];
-                ap_inlined=inlined_attribute;
-                ap_specialised=Default_specialise})
-  | Tmod_constraint(arg, _, _, ccarg) ->
-      transl_module (compose_coercions cc ccarg) rootpath arg
-  | Tmod_unpack(arg, _) ->
-      apply_coercion loc Strict cc (Translcore.transl_exp arg)
-
-and transl_struct loc fields cc rootpath str =
-  transl_structure loc fields cc rootpath str.str_final_env str.str_items
-
-(* The function  transl_structure is called by  the bytecode compiler.
-   Some effort is made to compile in top to bottom order, in order to display
-   warning by increasing locations. *)
-and transl_structure loc fields cc rootpath final_env = function
-    [] ->
-      let body, size =
-        match cc with
-          Tcoerce_none ->
-            Lprim(Pmakeblock(0, Immutable, None),
-                  List.map (fun id -> Lvar id) (List.rev fields), loc),
-              List.length fields
-        | Tcoerce_structure(pos_cc_list, id_pos_list) ->
-                (* Do not ignore id_pos_list ! *)
-            (*Format.eprintf "%a@.@[" Includemod.print_coercion cc;
-            List.iter (fun l -> Format.eprintf "%a@ " Ident.print l)
-              fields;
-            Format.eprintf "@]@.";*)
-            let v = Array.of_list (List.rev fields) in
-            let get_field pos =
-              if pos < 0 then lambda_unit
-              else Lvar v.(pos)
-            in
-            let ids = List.fold_right Ident.Set.add fields Ident.Set.empty in
-            let lam =
-              Lprim(Pmakeblock(0, Immutable, None),
-                  List.map
-                    (fun (pos, cc) ->
-                      match cc with
-                        Tcoerce_primitive p ->
-                          Translprim.transl_primitive p.pc_loc
-                            p.pc_desc p.pc_env p.pc_type None
-                      | _ -> apply_coercion loc Strict cc (get_field pos))
-                    pos_cc_list, loc)
-            and id_pos_list =
-              List.filter (fun (id,_,_) -> not (Ident.Set.mem id ids))
-                id_pos_list
-            in
-            wrap_id_pos_list loc id_pos_list get_field lam,
-              List.length pos_cc_list
-        | _ ->
-            fatal_error "Translmod.transl_structure"
-      in
-      (* This debugging event provides information regarding the structure
-         items. It is ignored by the OCaml debugger but is used by
-         Js_of_ocaml to preserve variable names. *)
-      (if !Clflags.debug && not !Clflags.native_code then
-         Levent(body,
-                {lev_loc = loc;
-                 lev_kind = Lev_pseudo;
-                 lev_repr = None;
-                 lev_env = final_env})
-       else
-         body),
-      size
-  | item :: rem ->
-      match item.str_desc with
-      | Tstr_eval (expr, _) ->
-          let body, size =
-            transl_structure loc fields cc rootpath final_env rem
-          in
-          Lsequence(transl_exp expr, body), size
-      | Tstr_value(rec_flag, pat_expr_list) ->
-          (* Translate bindings first *)
-          let mk_lam_let =  transl_let rec_flag pat_expr_list in
-          let ext_fields = rev_let_bound_idents pat_expr_list @ fields in
-          (* Then, translate remainder of struct *)
-          let body, size =
-            transl_structure loc ext_fields cc rootpath final_env rem
-          in
-          mk_lam_let body, size
-      | Tstr_primitive descr ->
-          record_primitive descr.val_val;
-          transl_structure loc fields cc rootpath final_env rem
-      | Tstr_type _ ->
-          transl_structure loc fields cc rootpath final_env rem
-      | Tstr_typext(tyext) ->
-          let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in
-          let body, size =
-            transl_structure loc (List.rev_append ids fields)
-              cc rootpath final_env rem
-          in
-          transl_type_extension item.str_env rootpath tyext body, size
-      | Tstr_exception ext ->
-          let id = ext.tyexn_constructor.ext_id in
-          let path = field_path rootpath id in
-          let body, size =
-            transl_structure loc (id :: fields) cc rootpath final_env rem
-          in
-          Llet(Strict, Pgenval, id,
-               transl_extension_constructor item.str_env
-                                            path
-                                            ext.tyexn_constructor, body),
-          size
-      | Tstr_module ({mb_presence=Mp_present} as mb) ->
-          let id = mb.mb_id in
-          (* Translate module first *)
-          let module_body =
-            transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr
-          in
-          let module_body =
-            Translattribute.add_inline_attribute module_body mb.mb_loc
-                                                 mb.mb_attributes
-          in
-          (* Translate remainder second *)
-          let body, size =
-            transl_structure loc (id :: fields) cc rootpath final_env rem
-          in
-          let module_body =
-            Levent (module_body, {
-              lev_loc = mb.mb_loc;
-              lev_kind = Lev_module_definition id;
-              lev_repr = None;
-              lev_env = Env.empty;
-            })
-          in
-          Llet(pure_module mb.mb_expr, Pgenval, id,
-               module_body,
-               body), size
-      | Tstr_module {mb_presence=Mp_absent} ->
-          transl_structure loc fields cc rootpath final_env rem
-      | Tstr_recmodule bindings ->
-          let ext_fields =
-            List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields
-          in
-          let body, size =
-            transl_structure loc ext_fields cc rootpath final_env rem
-          in
-          let lam =
-            compile_recmodule
-              (fun id modl loc ->
-                 let module_body =
-                   transl_module Tcoerce_none (field_path rootpath id) modl
-                 in
-                 Levent (module_body, {
-                   lev_loc = loc;
-                   lev_kind = Lev_module_definition id;
-                   lev_repr = None;
-                   lev_env = Env.empty;
-                 }))
-              bindings
-              body
-          in
-          lam, size
-      | Tstr_class cl_list ->
-          let (ids, class_bindings) = transl_class_bindings cl_list in
-          let body, size =
-            transl_structure loc (List.rev_append ids fields)
-              cc rootpath final_env rem
-          in
-          Lletrec(class_bindings, body), size
-      | Tstr_include incl ->
-          let ids = bound_value_identifiers incl.incl_type in
-          let modl = incl.incl_mod in
-          let mid = Ident.create_local "include" in
-          let rec rebind_idents pos newfields = function
-              [] ->
-                transl_structure loc newfields cc rootpath final_env rem
-            | id :: ids ->
-                let body, size =
-                  rebind_idents (pos + 1) (id :: newfields) ids
-                in
-                Llet(Alias, Pgenval, id,
-                     Lprim(Pfield pos, [Lvar mid], incl.incl_loc), body),
-                size
-          in
-          let body, size = rebind_idents 0 fields ids in
-          Llet(pure_module modl, Pgenval, mid,
-               transl_module Tcoerce_none None modl, body),
-          size
-
-      | Tstr_open od ->
-          let pure = pure_module od.open_expr in
-          (* this optimization shouldn't be needed because Simplif would
-             actually remove the [Llet] when it's not used.
-             But since [scan_used_globals] runs before Simplif, we need to do
-             it. *)
-          begin match od.open_bound_items with
-          | [] when pure = Alias ->
-              transl_structure loc fields cc rootpath final_env rem
-          | _ ->
-              let ids = bound_value_identifiers od.open_bound_items in
-              let mid = Ident.create_local "open" in
-              let rec rebind_idents pos newfields = function
-                  [] ->
-                  transl_structure loc newfields cc rootpath final_env rem
-                | id :: ids ->
-                  let body, size =
-                    rebind_idents (pos + 1) (id :: newfields) ids
-                  in
-                  Llet(Alias, Pgenval, id,
-                      Lprim(Pfield pos, [Lvar mid], od.open_loc), body),
-                  size
-              in
-              let body, size = rebind_idents 0 fields ids in
-              Llet(pure, Pgenval, mid,
-                    transl_module Tcoerce_none None od.open_expr, body), size
-          end
-      | Tstr_modtype _
-      | Tstr_class_type _
-      | Tstr_attribute _ ->
-          transl_structure loc fields cc rootpath final_env rem
-
-(* Update forward declaration in Translcore *)
-let _ =
-  Translcore.transl_module := transl_module
-
-(* Introduce dependencies on modules referenced only by "external". *)
-
-let scan_used_globals lam =
-  let globals = ref Ident.Set.empty in
-  let rec scan lam =
-    Lambda.iter_head_constructor scan lam;
-    match lam with
-      Lprim ((Pgetglobal id | Psetglobal id), _, _) ->
-        globals := Ident.Set.add id !globals
-    | _ -> ()
-  in
-  scan lam; !globals
-
-let required_globals ~flambda body =
-  let globals = scan_used_globals body in
-  let add_global id req =
-    if not flambda && Ident.Set.mem id globals then
-      req
-    else
-      Ident.Set.add id req
-  in
-  let required =
-    List.fold_left
-      (fun acc path -> add_global (Path.head path) acc)
-      (if flambda then globals else Ident.Set.empty)
-      (Translprim.get_used_primitives ())
-  in
-  let required =
-    List.fold_right add_global (Env.get_required_globals ()) required
-  in
-  Env.reset_required_globals ();
-  Translprim.clear_used_primitives ();
-  required
-
-(* Compile an implementation *)
-
-let transl_implementation_flambda module_name (str, cc) =
-  reset_labels ();
-  primitive_declarations := [];
-  Translprim.clear_used_primitives ();
-  let module_id = Ident.create_persistent module_name in
-  let body, size =
-    Translobj.transl_label_init
-      (fun () -> transl_struct Location.none [] cc
-                   (global_path module_id) str)
-  in
-  { module_ident = module_id;
-    main_module_block_size = size;
-    required_globals = required_globals ~flambda:true body;
-    code = body }
-
-let transl_implementation module_name (str, cc) =
-  let implementation =
-    transl_implementation_flambda module_name (str, cc)
-  in
-  let code =
-    Lprim (Psetglobal implementation.module_ident, [implementation.code],
-           Location.none)
-  in
-  { implementation with code }
-
-(* Build the list of value identifiers defined by a toplevel structure
-   (excluding primitive declarations). *)
-
-let rec defined_idents = function
-    [] -> []
-  | item :: rem ->
-    match item.str_desc with
-    | Tstr_eval _ -> defined_idents rem
-    | Tstr_value(_rec_flag, pat_expr_list) ->
-      let_bound_idents pat_expr_list @ defined_idents rem
-    | Tstr_primitive _ -> defined_idents rem
-    | Tstr_type _ -> defined_idents rem
-    | Tstr_typext tyext ->
-      List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
-      @ defined_idents rem
-    | Tstr_exception ext -> ext.tyexn_constructor.ext_id :: defined_idents rem
-    | Tstr_module {mb_id; mb_presence=Mp_present} -> mb_id :: defined_idents rem
-    | Tstr_module {mb_presence=Mp_absent} -> defined_idents rem
-    | Tstr_recmodule decls ->
-      List.map (fun mb -> mb.mb_id) decls @ defined_idents rem
-    | Tstr_modtype _ -> defined_idents rem
-    | Tstr_open od ->
-      bound_value_identifiers od.open_bound_items @ defined_idents rem
-    | Tstr_class cl_list ->
-      List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ defined_idents rem
-    | Tstr_class_type _ -> defined_idents rem
-    | Tstr_include incl ->
-      bound_value_identifiers incl.incl_type @ defined_idents rem
-    | Tstr_attribute _ -> defined_idents rem
-
-(* second level idents (module M = struct ... let id = ... end),
-   and all sub-levels idents *)
-let rec more_idents = function
-    [] -> []
-  | item :: rem ->
-    match item.str_desc with
-    | Tstr_eval _ -> more_idents rem
-    | Tstr_value _ -> more_idents rem
-    | Tstr_primitive _ -> more_idents rem
-    | Tstr_type _ -> more_idents rem
-    | Tstr_typext _ -> more_idents rem
-    | Tstr_exception _ -> more_idents rem
-    | Tstr_recmodule _ -> more_idents rem
-    | Tstr_modtype _ -> more_idents rem
-    | Tstr_open od ->
-        let rest = more_idents rem in
-        begin match od.open_expr.mod_desc with
-        | Tmod_structure str -> all_idents str.str_items @ rest
-        | _ -> rest
-        end
-    | Tstr_class _ -> more_idents rem
-    | Tstr_class_type _ -> more_idents rem
-    | Tstr_include{incl_mod={mod_desc =
-                             Tmod_constraint ({mod_desc = Tmod_structure str},
-                                              _, _, _)}} ->
-        all_idents str.str_items @ more_idents rem
-    | Tstr_include _ -> more_idents rem
-    | Tstr_module
-        {mb_presence=Mp_present; mb_expr={mod_desc = Tmod_structure str}}
-    | Tstr_module
-        {mb_presence=Mp_present;
-         mb_expr={mod_desc=
-           Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} ->
-        all_idents str.str_items @ more_idents rem
-    | Tstr_module _ -> more_idents rem
-    | Tstr_attribute _ -> more_idents rem
-
-and all_idents = function
-    [] -> []
-  | item :: rem ->
-    match item.str_desc with
-    | Tstr_eval _ -> all_idents rem
-    | Tstr_value(_rec_flag, pat_expr_list) ->
-      let_bound_idents pat_expr_list @ all_idents rem
-    | Tstr_primitive _ -> all_idents rem
-    | Tstr_type _ -> all_idents rem
-    | Tstr_typext tyext ->
-      List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
-      @ all_idents rem
-    | Tstr_exception ext -> ext.tyexn_constructor.ext_id :: all_idents rem
-    | Tstr_recmodule decls ->
-      List.map (fun mb -> mb.mb_id) decls @ all_idents rem
-    | Tstr_modtype _ -> all_idents rem
-    | Tstr_open od ->
-        let rest = all_idents rem in
-        begin match od.open_expr.mod_desc with
-        | Tmod_structure str ->
-          bound_value_identifiers od.open_bound_items
-          @ all_idents str.str_items
-          @ rest
-        | _ -> bound_value_identifiers od.open_bound_items @ rest
-        end
-    | Tstr_class cl_list ->
-      List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ all_idents rem
-    | Tstr_class_type _ -> all_idents rem
-
-    | Tstr_include{incl_type; incl_mod={mod_desc =
-                             Tmod_constraint ({mod_desc = Tmod_structure str},
-                                              _, _, _)}} ->
-        bound_value_identifiers incl_type
-        @ all_idents str.str_items
-        @ all_idents rem
-    | Tstr_include incl ->
-      bound_value_identifiers incl.incl_type @ all_idents rem
-
-    | Tstr_module
-        {mb_id;mb_presence=Mp_present;mb_expr={mod_desc = Tmod_structure str}}
-    | Tstr_module
-        {mb_id;mb_presence=Mp_present;
-         mb_expr=
-           {mod_desc =
-              Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} ->
-        mb_id :: all_idents str.str_items @ all_idents rem
-    | Tstr_module {mb_id;mb_presence=Mp_present} -> mb_id :: all_idents rem
-    | Tstr_module {mb_presence=Mp_absent} -> all_idents rem
-    | Tstr_attribute _ -> all_idents rem
-
-
-(* A variant of transl_structure used to compile toplevel structure definitions
-   for the native-code compiler. Store the defined values in the fields
-   of the global as soon as they are defined, in order to reduce register
-   pressure.  Also rewrites the defining expressions so that they
-   refer to earlier fields of the structure through the fields of
-   the global, not by their names.
-   "map" is a table from defined idents to (pos in global block, coercion).
-   "prim" is a list of (pos in global block, primitive declaration). *)
-
-let transl_store_subst = ref Ident.Map.empty
-  (** In the native toplevel, this reference is threaded through successive
-      calls of transl_store_structure *)
-
-let nat_toplevel_name id =
-  try match Ident.Map.find id !transl_store_subst with
-    | Lprim(Pfield pos, [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos)
-    | _ -> raise Not_found
-  with Not_found ->
-    fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id)
-
-let field_of_str loc str =
-  let ids = Array.of_list (defined_idents str.str_items) in
-  fun (pos, cc) ->
-    match cc with
-    | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type; } ->
-        Translprim.transl_primitive pc_loc pc_desc pc_env pc_type None
-    | Tcoerce_alias (env, path, cc) ->
-        let lam = transl_module_path loc env path in
-        apply_coercion loc Alias cc lam
-    | _ -> apply_coercion loc Strict cc (Lvar ids.(pos))
-
-
-let transl_store_structure glob map prims aliases str =
-  let no_env_update _ _ env = env in
-  let rec transl_store rootpath subst cont = function
-    [] ->
-      transl_store_subst := subst;
-      Lambda.subst no_env_update subst cont
-    | item :: rem ->
-        match item.str_desc with
-        | Tstr_eval (expr, _attrs) ->
-            Lsequence(Lambda.subst no_env_update subst (transl_exp expr),
-                      transl_store rootpath subst cont rem)
-        | Tstr_value(rec_flag, pat_expr_list) ->
-            let ids = let_bound_idents pat_expr_list in
-            let lam =
-              transl_let rec_flag pat_expr_list
-                (store_idents Location.none ids)
-            in
-            Lsequence(Lambda.subst no_env_update subst lam,
-                      transl_store rootpath
-                        (add_idents false ids subst) cont rem)
-        | Tstr_primitive descr ->
-            record_primitive descr.val_val;
-            transl_store rootpath subst cont rem
-        | Tstr_type _ ->
-            transl_store rootpath subst cont rem
-        | Tstr_typext(tyext) ->
-            let ids =
-              List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
-            in
-            let lam =
-              transl_type_extension item.str_env rootpath tyext
-                                    (store_idents Location.none ids)
-            in
-            Lsequence(Lambda.subst no_env_update subst lam,
-                      transl_store rootpath
-                        (add_idents false ids subst) cont rem)
-        | Tstr_exception ext ->
-            let id = ext.tyexn_constructor.ext_id in
-            let path = field_path rootpath id in
-            let lam =
-              transl_extension_constructor item.str_env
-                                           path
-                                           ext.tyexn_constructor
-            in
-            Lsequence(Llet(Strict, Pgenval, id,
-                           Lambda.subst no_env_update subst lam,
-                           store_ident ext.tyexn_constructor.ext_loc id),
-                      transl_store rootpath
-                        (add_ident false id subst) cont rem)
-        | Tstr_module{mb_id=id;mb_loc=loc;mb_presence=Mp_present;
-                      mb_expr={mod_desc = Tmod_structure str} as mexp;
-                      mb_attributes} ->
-            List.iter (Translattribute.check_attribute_on_module mexp)
-              mb_attributes;
-            let lam =
-              transl_store (field_path rootpath id) subst
-                lambda_unit str.str_items
-            in
-            (* Careful: see next case *)
-            let subst = !transl_store_subst in
-            Lsequence(lam,
-                      Llet(Strict, Pgenval, id,
-                           Lambda.subst no_env_update subst
-                             (Lprim(Pmakeblock(0, Immutable, None),
-                                    List.map (fun id -> Lvar id)
-                                      (defined_idents str.str_items), loc)),
-                           Lsequence(store_ident loc id,
-                                     transl_store rootpath
-                                                  (add_ident true id subst)
-                                                  cont rem)))
-        | Tstr_module{
-            mb_id=id;mb_loc=loc;mb_presence=Mp_present;
-            mb_expr= {
-              mod_desc = Tmod_constraint (
-                  {mod_desc = Tmod_structure str} as mexp, _, _,
-                  (Tcoerce_structure (map, _) as _cc))};
-            mb_attributes
-          } ->
-            (*    Format.printf "coerc id %s: %a@." (Ident.unique_name id)
-                                Includemod.print_coercion cc; *)
-            List.iter (Translattribute.check_attribute_on_module mexp)
-              mb_attributes;
-            let lam =
-              transl_store (field_path rootpath id) subst
-                lambda_unit str.str_items
-            in
-            (* Careful: see next case *)
-            let subst = !transl_store_subst in
-            let field = field_of_str loc str in
-            Lsequence(lam,
-                      Llet(Strict, Pgenval, id,
-                           Lambda.subst no_env_update subst
-                             (Lprim(Pmakeblock(0, Immutable, None),
-                                    List.map field map, loc)),
-                           Lsequence(store_ident loc id,
-                                     transl_store rootpath
-                                                  (add_ident true id subst)
-                                                  cont rem)))
-        | Tstr_module
-            {mb_id=id; mb_presence=Mp_present; mb_expr=modl;
-             mb_loc=loc; mb_attributes} ->
-            let lam =
-              Translattribute.add_inline_attribute
-                (transl_module Tcoerce_none (field_path rootpath id) modl)
-                loc mb_attributes
-            in
-            (* Careful: the module value stored in the global may be different
-               from the local module value, in case a coercion is applied.
-               If so, keep using the local module value (id) in the remainder of
-               the compilation unit (add_ident true returns subst unchanged).
-               If not, we can use the value from the global
-               (add_ident true adds id -> Pgetglobal... to subst). *)
-            Llet(Strict, Pgenval, id, Lambda.subst no_env_update subst lam,
-                 Lsequence(store_ident loc id,
-                           transl_store rootpath (add_ident true id subst)
-                             cont rem))
-        | Tstr_module {mb_presence=Mp_absent} ->
-            transl_store rootpath subst cont rem
-        | Tstr_recmodule bindings ->
-            let ids = List.map (fun mb -> mb.mb_id) bindings in
-            compile_recmodule
-              (fun id modl _loc ->
-                 Lambda.subst no_env_update subst
-                   (transl_module Tcoerce_none
-                      (field_path rootpath id) modl))
-              bindings
-              (Lsequence(store_idents Location.none ids,
-                         transl_store rootpath (add_idents true ids subst)
-                           cont rem))
-        | Tstr_class cl_list ->
-            let (ids, class_bindings) = transl_class_bindings cl_list in
-            let lam =
-              Lletrec(class_bindings, store_idents Location.none ids)
-            in
-            Lsequence(Lambda.subst no_env_update subst lam,
-                      transl_store rootpath (add_idents false ids subst)
-                        cont rem)
-
-        | Tstr_include{
-            incl_loc=loc;
-            incl_mod= {
-              mod_desc = Tmod_constraint (
-                  ({mod_desc = Tmod_structure str} as mexp), _, _,
-                  (Tcoerce_structure (map, _)))};
-            incl_attributes;
-            incl_type;
-          } ->
-            List.iter (Translattribute.check_attribute_on_module mexp)
-              incl_attributes;
-            (* Shouldn't we use mod_attributes instead of incl_attributes?
-               Same question for the Tstr_module cases above, btw. *)
-            let lam =
-              transl_store None subst lambda_unit str.str_items
-                (* It is tempting to pass rootpath instead of None
-                   in order to give a more precise name to exceptions
-                   in the included structured, but this would introduce
-                   a difference of behavior compared to bytecode. *)
-            in
-            let subst = !transl_store_subst in
-            let field = field_of_str loc str in
-            let ids0 = bound_value_identifiers incl_type in
-            let rec loop ids args =
-              match ids, args with
-              | [], [] ->
-                  transl_store rootpath (add_idents true ids0 subst)
-                    cont rem
-              | id :: ids, arg :: args ->
-                  Llet(Alias, Pgenval, id,
-                       Lambda.subst no_env_update subst (field arg),
-                       Lsequence(store_ident loc id,
-                                 loop ids args))
-              | _ -> assert false
-            in
-            Lsequence(lam, loop ids0 map)
-
-
-        | Tstr_include incl ->
-            let ids = bound_value_identifiers incl.incl_type in
-            let modl = incl.incl_mod in
-            let mid = Ident.create_local "include" in
-            let loc = incl.incl_loc in
-            let rec store_idents pos = function
-              | [] ->
-                transl_store rootpath (add_idents true ids subst) cont rem
-              | id :: idl ->
-                  Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid], loc),
-                       Lsequence(store_ident loc id,
-                                 store_idents (pos + 1) idl))
-            in
-            Llet(Strict, Pgenval, mid,
-                 Lambda.subst no_env_update subst
-                   (transl_module Tcoerce_none None modl),
-                 store_idents 0 ids)
-        | Tstr_open od ->
-            begin match od.open_expr.mod_desc with
-            | Tmod_structure str ->
-                let lam =
-                  transl_store rootpath subst lambda_unit str.str_items
-                in
-                let ids = Array.of_list (defined_idents str.str_items) in
-                let ids0 = bound_value_identifiers od.open_bound_items in
-                let subst = !transl_store_subst in
-                let rec store_idents pos = function
-                  | [] -> transl_store rootpath subst cont rem
-                  | id :: idl ->
-                      Llet(Alias, Pgenval, id, Lvar ids.(pos),
-                           Lsequence(store_ident od.open_loc id,
-                                     store_idents (pos + 1) idl))
-                in
-                Lsequence(lam, Lambda.subst no_env_update subst
-                                 (store_idents 0 ids0))
-            | _ ->
-                let pure = pure_module od.open_expr in
-                (* this optimization shouldn't be needed because Simplif would
-                   actually remove the [Llet] when it's not used.
-                   But since [scan_used_globals] runs before Simplif, we need to
-                   do it. *)
-                match od.open_bound_items with
-                | [] when pure = Alias -> transl_store rootpath subst cont rem
-                | _ ->
-                    let ids = bound_value_identifiers od.open_bound_items in
-                    let mid = Ident.create_local "open" in
-                    let loc = od.open_loc in
-                    let rec store_idents pos = function
-                        [] ->
-                          transl_store rootpath (add_idents true ids subst) cont
-                            rem
-                      | id :: idl ->
-                          Llet(Alias, Pgenval, id, Lprim(Pfield pos, [Lvar mid],
-                                                         loc),
-                               Lsequence(store_ident loc id,
-                                         store_idents (pos + 1) idl))
-                    in
-                    Llet(pure, Pgenval, mid,
-                         Lambda.subst no_env_update subst
-                           (transl_module Tcoerce_none None od.open_expr),
-                         store_idents 0 ids)
-          end
-        | Tstr_modtype _
-        | Tstr_class_type _
-        | Tstr_attribute _ ->
-            transl_store rootpath subst cont rem
-
-  and store_ident loc id =
-    try
-      let (pos, cc) = Ident.find_same id map in
-      let init_val = apply_coercion loc Alias cc (Lvar id) in
-      Lprim(Psetfield(pos, Pointer, Root_initialization),
-            [Lprim(Pgetglobal glob, [], loc); init_val],
-            loc)
-    with Not_found ->
-      fatal_error("Translmod.store_ident: " ^ Ident.unique_name id)
-
-  and store_idents loc idlist =
-    make_sequence (store_ident loc) idlist
-
-  and add_ident may_coerce id subst =
-    try
-      let (pos, cc) = Ident.find_same id map in
-      match cc with
-        Tcoerce_none ->
-          Ident.Map.add id
-            (Lprim(Pfield pos,
-                   [Lprim(Pgetglobal glob, [], Location.none)],
-                   Location.none))
-            subst
-      | _ ->
-          if may_coerce then subst else assert false
-    with Not_found ->
-      assert false
-
-  and add_idents may_coerce idlist subst =
-    List.fold_right (add_ident may_coerce) idlist subst
-
-  and store_primitive (pos, prim) cont =
-    Lsequence(Lprim(Psetfield(pos, Pointer, Root_initialization),
-                    [Lprim(Pgetglobal glob, [], Location.none);
-                     Translprim.transl_primitive Location.none
-                       prim.pc_desc prim.pc_env prim.pc_type None],
-                    Location.none),
-              cont)
-
-  and store_alias (pos, env, path, cc) =
-    let path_lam = transl_module_path Location.none env path in
-    let init_val = apply_coercion Location.none Strict cc path_lam in
-    Lprim(Psetfield(pos, Pointer, Root_initialization),
-          [Lprim(Pgetglobal glob, [], Location.none);
-           init_val],
-          Location.none)
-  in
-  let aliases = make_sequence store_alias aliases in
-  List.fold_right store_primitive prims
-    (transl_store (global_path glob) !transl_store_subst aliases str)
-
-(* Transform a coercion and the list of value identifiers defined by
-   a toplevel structure into a table [id -> (pos, coercion)],
-   with [pos] being the position in the global block where the value of
-   [id] must be stored, and [coercion] the coercion to be applied to it.
-   A given identifier may appear several times
-   in the coercion (if it occurs several times in the signature); remember
-   to assign it the position of its last occurrence.
-   Identifiers that are not exported are assigned positions at the
-   end of the block (beyond the positions of all exported idents).
-   Also compute the total size of the global block,
-   and the list of all primitives exported as values. *)
-
-let build_ident_map restr idlist more_ids =
-  let rec natural_map pos map prims aliases = function
-    | [] ->
-        (map, prims, aliases, pos)
-    | id :: rem ->
-        natural_map (pos+1)
-          (Ident.add id (pos, Tcoerce_none) map) prims aliases rem
-  in
-  let (map, prims, aliases, pos) =
-    match restr with
-    | Tcoerce_none ->
-        natural_map 0 Ident.empty [] [] idlist
-    | Tcoerce_structure (pos_cc_list, _id_pos_list) ->
-        (* ignore _id_pos_list as the ids are already bound *)
-        let idarray = Array.of_list idlist in
-        let rec export_map pos map prims aliases undef = function
-          | [] ->
-              natural_map pos map prims aliases undef
-          | (_source_pos, Tcoerce_primitive p) :: rem ->
-              export_map (pos + 1) map
-                ((pos, p) :: prims) aliases undef rem
-          | (_source_pos, Tcoerce_alias(env, path, cc)) :: rem ->
-              export_map (pos + 1) map prims
-                ((pos, env, path, cc) :: aliases) undef rem
-          | (source_pos, cc) :: rem ->
-              let id = idarray.(source_pos) in
-              export_map (pos + 1) (Ident.add id (pos, cc) map)
-                prims aliases (list_remove id undef) rem
-        in
-        export_map 0 Ident.empty [] [] idlist pos_cc_list
-    | _ ->
-        fatal_error "Translmod.build_ident_map"
-  in
-  natural_map pos map prims aliases more_ids
-
-(* Compile an implementation using transl_store_structure
-   (for the native-code compiler). *)
-
-let transl_store_gen module_name ({ str_items = str }, restr) topl =
-  reset_labels ();
-  primitive_declarations := [];
-  Translprim.clear_used_primitives ();
-  let module_id = Ident.create_persistent module_name in
-  let (map, prims, aliases, size) =
-    build_ident_map restr (defined_idents str) (more_idents str) in
-  let f = function
-    | [ { str_desc = Tstr_eval (expr, _attrs) } ] when topl ->
-        assert (size = 0);
-        Lambda.subst (fun _ _ env -> env) !transl_store_subst (transl_exp expr)
-    | str -> transl_store_structure module_id map prims aliases str
-  in
-  transl_store_label_init module_id size f str
-  (*size, transl_label_init (transl_store_structure module_id map prims str)*)
-
-let transl_store_phrases module_name str =
-  transl_store_gen module_name (str,Tcoerce_none) true
-
-let transl_store_implementation module_name (str, restr) =
-  let s = !transl_store_subst in
-  transl_store_subst := Ident.Map.empty;
-  let (i, code) = transl_store_gen module_name (str, restr) false in
-  transl_store_subst := s;
-  { Lambda.main_module_block_size = i;
-    code;
-    (* module_ident is not used by closure, but this allow to share
-       the type with the flambda version *)
-    module_ident = Ident.create_persistent module_name;
-    required_globals = required_globals ~flambda:true code }
-
-(* Compile a toplevel phrase *)
-
-let toploop_ident = Ident.create_persistent "Toploop"
-let toploop_getvalue_pos = 0 (* position of getvalue in module Toploop *)
-let toploop_setvalue_pos = 1 (* position of setvalue in module Toploop *)
-
-let aliased_idents = ref Ident.empty
-
-let set_toplevel_unique_name id =
-  aliased_idents :=
-    Ident.add id (Ident.unique_toplevel_name id) !aliased_idents
-
-let toplevel_name id =
-  try Ident.find_same id !aliased_idents
-  with Not_found -> Ident.name id
-
-let toploop_getvalue id =
-  Lapply{ap_should_be_tailcall=false;
-         ap_loc=Location.none;
-         ap_func=Lprim(Pfield toploop_getvalue_pos,
-                       [Lprim(Pgetglobal toploop_ident, [], Location.none)],
-                       Location.none);
-         ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)))];
-         ap_inlined=Default_inline;
-         ap_specialised=Default_specialise}
-
-let toploop_setvalue id lam =
-  Lapply{ap_should_be_tailcall=false;
-         ap_loc=Location.none;
-         ap_func=Lprim(Pfield toploop_setvalue_pos,
-                       [Lprim(Pgetglobal toploop_ident, [], Location.none)],
-                       Location.none);
-         ap_args=[Lconst(Const_base(Const_string (toplevel_name id, None)));
-                  lam];
-         ap_inlined=Default_inline;
-         ap_specialised=Default_specialise}
-
-let toploop_setvalue_id id = toploop_setvalue id (Lvar id)
-
-let close_toplevel_term (lam, ()) =
-  Ident.Set.fold (fun id l -> Llet(Strict, Pgenval, id,
-                                  toploop_getvalue id, l))
-                (free_variables lam) lam
-
-let transl_toplevel_item item =
-  match item.str_desc with
-    Tstr_eval (expr, _)
-  | Tstr_value(Nonrecursive,
-               [{vb_pat = {pat_desc=Tpat_any};vb_expr = expr}]) ->
-      (* special compilation for toplevel "let _ = expr", so
-         that Toploop can display the result of the expression.
-         Otherwise, the normal compilation would result
-         in a Lsequence returning unit. *)
-      transl_exp expr
-  | Tstr_value(rec_flag, pat_expr_list) ->
-      let idents = let_bound_idents pat_expr_list in
-      transl_let rec_flag pat_expr_list
-        (make_sequence toploop_setvalue_id idents)
-  | Tstr_typext(tyext) ->
-      let idents =
-        List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
-      in
-      (* we need to use unique name in case of multiple
-         definitions of the same extension constructor in the toplevel *)
-      List.iter set_toplevel_unique_name idents;
-        transl_type_extension item.str_env None tyext
-          (make_sequence toploop_setvalue_id idents)
-  | Tstr_exception ext ->
-      set_toplevel_unique_name ext.tyexn_constructor.ext_id;
-      toploop_setvalue ext.tyexn_constructor.ext_id
-        (transl_extension_constructor item.str_env None ext.tyexn_constructor)
-  | Tstr_module {mb_id=id; mb_presence=Mp_present; mb_expr=modl} ->
-      (* we need to use the unique name for the module because of issues
-         with "open" (PR#8133) *)
-      set_toplevel_unique_name id;
-      let lam = transl_module Tcoerce_none (Some(Pident id)) modl in
-      toploop_setvalue id lam
-  | Tstr_recmodule bindings ->
-      let idents = List.map (fun mb -> mb.mb_id) bindings in
-      compile_recmodule
-        (fun id modl _loc -> transl_module Tcoerce_none (Some(Pident id)) modl)
-        bindings
-        (make_sequence toploop_setvalue_id idents)
-  | Tstr_class cl_list ->
-      (* we need to use unique names for the classes because there might
-         be a value named identically *)
-      let (ids, class_bindings) = transl_class_bindings cl_list in
-      List.iter set_toplevel_unique_name ids;
-      Lletrec(class_bindings, make_sequence toploop_setvalue_id ids)
-  | Tstr_include incl ->
-      let ids = bound_value_identifiers incl.incl_type in
-      let modl = incl.incl_mod in
-      let mid = Ident.create_local "include" in
-      let rec set_idents pos = function
-        [] ->
-          lambda_unit
-      | id :: ids ->
-          Lsequence(toploop_setvalue id
-                      (Lprim(Pfield pos, [Lvar mid], Location.none)),
-                    set_idents (pos + 1) ids) in
-      Llet(Strict, Pgenval, mid,
-           transl_module Tcoerce_none None modl, set_idents 0 ids)
-  | Tstr_primitive descr ->
-      record_primitive descr.val_val;
-      lambda_unit
-  | Tstr_open od ->
-      let pure = pure_module od.open_expr in
-      (* this optimization shouldn't be needed because Simplif would
-          actually remove the [Llet] when it's not used.
-          But since [scan_used_globals] runs before Simplif, we need to do
-          it. *)
-      begin match od.open_bound_items with
-      | [] when pure = Alias -> lambda_unit
-      | _ ->
-          let ids = bound_value_identifiers od.open_bound_items in
-          let mid = Ident.create_local "open" in
-          let rec set_idents pos = function
-              [] ->
-                lambda_unit
-            | id :: ids ->
-                Lsequence(toploop_setvalue id
-                            (Lprim(Pfield pos, [Lvar mid], Location.none)),
-                          set_idents (pos + 1) ids)
-          in
-          Llet(pure, Pgenval, mid,
-               transl_module Tcoerce_none None od.open_expr, set_idents 0 ids)
-      end
-  | Tstr_modtype _
-  | Tstr_module {mb_presence=Mp_absent}
-  | Tstr_type _
-  | Tstr_class_type _
-  | Tstr_attribute _ ->
-      lambda_unit
-
-let transl_toplevel_item_and_close itm =
-  close_toplevel_term
-    (transl_label_init (fun () -> transl_toplevel_item itm, ()))
-
-let transl_toplevel_definition str =
-  reset_labels ();
-  Translprim.clear_used_primitives ();
-  make_sequence transl_toplevel_item_and_close str.str_items
-
-(* Compile the initialization code for a packed library *)
-
-let get_component = function
-    None -> Lconst const_unit
-  | Some id -> Lprim(Pgetglobal id, [], Location.none)
-
-let transl_package_flambda component_names coercion =
-  let size =
-    match coercion with
-    | Tcoerce_none -> List.length component_names
-    | Tcoerce_structure (l, _) -> List.length l
-    | Tcoerce_functor _
-    | Tcoerce_primitive _
-    | Tcoerce_alias _ -> assert false
-  in
-  size,
-  apply_coercion Location.none Strict coercion
-    (Lprim(Pmakeblock(0, Immutable, None),
-           List.map get_component component_names,
-           Location.none))
-
-let transl_package component_names target_name coercion =
-  let components =
-    Lprim(Pmakeblock(0, Immutable, None),
-          List.map get_component component_names, Location.none) in
-  Lprim(Psetglobal target_name,
-        [apply_coercion Location.none Strict coercion components],
-        Location.none)
-  (*
-  let components =
-    match coercion with
-      Tcoerce_none ->
-        List.map get_component component_names
-    | Tcoerce_structure (pos_cc_list, id_pos_list) ->
-              (* ignore id_pos_list as the ids are already bound *)
-        let g = Array.of_list component_names in
-        List.map
-          (fun (pos, cc) -> apply_coercion Strict cc (get_component g.(pos)))
-          pos_cc_list
-    | _ ->
-        assert false in
-  Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)])
-   *)
-
-let transl_store_package component_names target_name coercion =
-  let rec make_sequence fn pos arg =
-    match arg with
-      [] -> lambda_unit
-    | hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in
-  match coercion with
-    Tcoerce_none ->
-      (List.length component_names,
-       make_sequence
-         (fun pos id ->
-           Lprim(Psetfield(pos, Pointer, Root_initialization),
-                 [Lprim(Pgetglobal target_name, [], Location.none);
-                  get_component id],
-                 Location.none))
-         0 component_names)
-  | Tcoerce_structure (pos_cc_list, _id_pos_list) ->
-      let components =
-        Lprim(Pmakeblock(0, Immutable, None),
-              List.map get_component component_names,
-              Location.none)
-      in
-      let blk = Ident.create_local "block" in
-      (List.length pos_cc_list,
-       Llet (Strict, Pgenval, blk,
-             apply_coercion Location.none Strict coercion components,
-             make_sequence
-               (fun pos _id ->
-                 Lprim(Psetfield(pos, Pointer, Root_initialization),
-                       [Lprim(Pgetglobal target_name, [], Location.none);
-                        Lprim(Pfield pos, [Lvar blk], Location.none)],
-                       Location.none))
-               0 pos_cc_list))
-  (*
-              (* ignore id_pos_list as the ids are already bound *)
-      let id = Array.of_list component_names in
-      (List.length pos_cc_list,
-       make_sequence
-         (fun dst (src, cc) ->
-           Lprim(Psetfield(dst, false),
-                 [Lprim(Pgetglobal target_name, []);
-                  apply_coercion Strict cc (get_component id.(src))]))
-         0 pos_cc_list)
-  *)
-  | _ -> assert false
-
-(* Error report *)
-
-open Format
-
-let print_cycle ppf cycle =
-  let print_ident ppf (x,_) = Format.pp_print_string ppf (Ident.name x) in
-  let pp_sep ppf () = fprintf ppf "@ -> " in
-  Format.fprintf ppf "%a%a%s"
-    (Format.pp_print_list ~pp_sep print_ident) cycle
-    pp_sep ()
-    (Ident.name @@ fst @@ List.hd cycle)
-(* we repeat the first element to make the cycle more apparent *)
-
-let explanation_submsg (id, {reason;loc;subid}) =
-  let print fmt =
-    let printer = Format.dprintf fmt (Ident.name id) (Ident.name subid) in
-    Location.mkloc printer loc in
-  match reason with
-  | Unsafe_module_binding -> print "Module %s defines an unsafe module, %s ."
-  | Unsafe_functor -> print "Module %s defines an unsafe functor, %s ."
-  | Unsafe_typext ->
-      print "Module %s defines an unsafe extension constructor, %s ."
-  | Unsafe_non_function -> print "Module %s defines an unsafe value, %s ."
-
-let report_error loc = function
-  | Circular_dependency cycle ->
-      let[@manual.ref "s-recursive-modules"] chapter, section = 8, 2 in
-      Location.errorf ~loc ~sub:(List.map explanation_submsg cycle)
-        "Cannot safely evaluate the definition of the following cycle@ \
-         of recursively-defined modules:@ %a.@ \
-         There are no safe modules in this cycle@ (see manual section %d.%d)."
-        print_cycle cycle chapter section
-  | Conflicting_inline_attributes ->
-      Location.errorf "@[Conflicting 'inline' attributes@]"
-
-let () =
-  Location.register_error_of_exn
-    (function
-      | Error (loc, err) -> Some (report_error loc err)
-      | _ ->
-        None
-    )
-
-let reset () =
-  primitive_declarations := [];
-  transl_store_subst := Ident.Map.empty;
-  aliased_idents := Ident.empty;
-  Env.reset_required_globals ();
-  Translprim.clear_used_primitives ()
diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli
deleted file mode 100644
index d0898c769a..0000000000
--- a/bytecomp/translmod.mli
+++ /dev/null
@@ -1,61 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 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.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Translation from typed abstract syntax to lambda terms,
-   for the module language *)
-
-open Typedtree
-open Lambda
-
-val transl_implementation:
-      string -> structure * module_coercion -> Lambda.program
-val transl_store_phrases: string -> structure -> int * lambda
-val transl_store_implementation:
-      string -> structure * module_coercion -> Lambda.program
-
-val transl_implementation_flambda:
-  string -> structure * module_coercion -> Lambda.program
-
-val transl_toplevel_definition: structure -> lambda
-val transl_package:
-      Ident.t option list -> Ident.t -> module_coercion -> lambda
-val transl_store_package:
-      Ident.t option list -> Ident.t -> module_coercion -> int * lambda
-
-val transl_package_flambda:
-      Ident.t option list -> module_coercion -> int * lambda
-
-val toplevel_name: Ident.t -> string
-val nat_toplevel_name: Ident.t -> Ident.t * int
-
-val primitive_declarations: Primitive.description list ref
-
-type unsafe_component =
-  | Unsafe_module_binding
-  | Unsafe_functor
-  | Unsafe_non_function
-  | Unsafe_typext
-
-type unsafe_info = { reason:unsafe_component; loc:Location.t; subid:Ident.t }
-
-type error =
-  Circular_dependency of (Ident.t * unsafe_info) list
-| Conflicting_inline_attributes
-
-exception Error of Location.t * error
-
-val report_error: Location.t -> error -> Location.error
-
-val reset: unit -> unit
diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml
deleted file mode 100644
index ce06353879..0000000000
--- a/bytecomp/translobj.ml
+++ /dev/null
@@ -1,199 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*          Jerome Vouillon, 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 Asttypes
-open Lambda
-
-(* Get oo primitives identifiers *)
-
-let oo_prim = Lambda.transl_prim "CamlinternalOO"
-
-(* Share blocks *)
-
-let consts : (structured_constant, Ident.t) Hashtbl.t = Hashtbl.create 17
-
-let share c =
-  match c with
-    Const_block (_n, l) when l <> [] ->
-      begin try
-        Lvar (Hashtbl.find consts c)
-      with Not_found ->
-        let id = Ident.create_local "shared" in
-        Hashtbl.add consts c id;
-        Lvar id
-      end
-  | _ -> Lconst c
-
-(* Collect labels *)
-
-let cache_required = ref false
-let method_cache = ref lambda_unit
-let method_count = ref 0
-let method_table = ref []
-
-let meth_tag s = Lconst(Const_base(Const_int(Btype.hash_variant s)))
-
-let next_cache tag =
-  let n = !method_count in
-  incr method_count;
-  (tag, [!method_cache; Lconst(Const_base(Const_int n))])
-
-let rec is_path = function
-    Lvar _ | Lprim (Pgetglobal _, [], _) | Lconst _ -> true
-  | Lprim (Pfield _, [lam], _) -> is_path lam
-  | Lprim ((Parrayrefu _ | Parrayrefs _), [lam1; lam2], _) ->
-      is_path lam1 && is_path lam2
-  | _ -> false
-
-let meth obj lab =
-  let tag = meth_tag lab in
-  if not (!cache_required && !Clflags.native_code) then (tag, []) else
-  if not (is_path obj) then next_cache tag else
-  try
-    let r = List.assoc obj !method_table in
-    try
-      (tag, List.assoc tag !r)
-    with Not_found ->
-      let p = next_cache tag in
-      r := p :: !r;
-      p
-  with Not_found ->
-    let p = next_cache tag in
-    method_table := (obj, ref [p]) :: !method_table;
-    p
-
-let reset_labels () =
-  Hashtbl.clear consts;
-  method_count := 0;
-  method_table := []
-
-(* Insert labels *)
-
-let int n = Lconst (Const_base (Const_int n))
-
-let prim_makearray =
-  Primitive.simple ~name:"caml_make_vect" ~arity:2 ~alloc:true
-
-(* Also use it for required globals *)
-let transl_label_init_general f =
-  let expr, size = f () in
-  let expr =
-    Hashtbl.fold
-      (fun c id expr -> Llet(Alias, Pgenval, id, Lconst c, expr))
-      consts expr
-  in
-  (*let expr =
-    List.fold_right
-      (fun id expr -> Lsequence(Lprim(Pgetglobal id, [], Location.none), expr))
-      (Env.get_required_globals ()) expr
-  in
-  Env.reset_required_globals ();*)
-  reset_labels ();
-  expr, size
-
-let transl_label_init_flambda f =
-  assert(Config.flambda);
-  let method_cache_id = Ident.create_local "method_cache" in
-  method_cache := Lvar method_cache_id;
-  (* Calling f (usually Translmod.transl_struct) requires the
-     method_cache variable to be initialised to be able to generate
-     method accesses. *)
-  let expr, size = f () in
-  let expr =
-    if !method_count = 0 then expr
-    else
-      Llet (Strict, Pgenval, method_cache_id,
-        Lprim (Pccall prim_makearray,
-               [int !method_count; int 0],
-               Location.none),
-        expr)
-  in
-  transl_label_init_general (fun () -> expr, size)
-
-let transl_store_label_init glob size f arg =
-  assert(not Config.flambda);
-  assert(!Clflags.native_code);
-  method_cache := Lprim(Pfield size,
-                        [Lprim(Pgetglobal glob, [], Location.none)],
-                        Location.none);
-  let expr = f arg in
-  let (size, expr) =
-    if !method_count = 0 then (size, expr) else
-    (size+1,
-     Lsequence(
-     Lprim(Psetfield(size, Pointer, Root_initialization),
-           [Lprim(Pgetglobal glob, [], Location.none);
-            Lprim (Pccall prim_makearray,
-                   [int !method_count; int 0],
-                   Location.none)],
-           Location.none),
-     expr))
-  in
-  let lam, size = transl_label_init_general (fun () -> (expr, size)) in
-  size, lam
-
-let transl_label_init f =
-  if !Clflags.native_code then
-    transl_label_init_flambda f
-  else
-    transl_label_init_general f
-
-(* Share classes *)
-
-let wrapping = ref false
-let top_env = ref Env.empty
-let classes = ref []
-let method_ids = ref Ident.Set.empty
-
-let oo_add_class id =
-  classes := id :: !classes;
-  (!top_env, !cache_required)
-
-let oo_wrap env req f x =
-  if !wrapping then
-    if !cache_required then f x else
-      Misc.protect_refs [Misc.R (cache_required, true)] (fun () ->
-          f x
-        )
-  else
-    Misc.protect_refs [Misc.R (wrapping, true); Misc.R (top_env, env)]
-      (fun () ->
-         cache_required := req;
-         classes := [];
-         method_ids := Ident.Set.empty;
-         let lambda = f x in
-         let lambda =
-           List.fold_left
-             (fun lambda id ->
-                Llet(StrictOpt, Pgenval, id,
-                     Lprim(Pmakeblock(0, Mutable, None),
-                           [lambda_unit; lambda_unit; lambda_unit],
-                           Location.none),
-                     lambda))
-             lambda !classes
-         in
-         lambda
-      )
-
-let reset () =
-  Hashtbl.clear consts;
-  cache_required := false;
-  method_cache := lambda_unit;
-  method_count := 0;
-  method_table := [];
-  wrapping := false;
-  top_env := Env.empty;
-  classes := [];
-  method_ids := Ident.Set.empty
diff --git a/bytecomp/translobj.mli b/bytecomp/translobj.mli
deleted file mode 100644
index c27053e961..0000000000
--- a/bytecomp/translobj.mli
+++ /dev/null
@@ -1,33 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 OCaml                                  *)
-(*                                                                        *)
-(*          Jerome Vouillon, 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 Lambda
-
-val oo_prim: string -> lambda
-
-val share: structured_constant -> lambda
-val meth: lambda -> string -> lambda * lambda list
-
-val reset_labels: unit -> unit
-val transl_label_init: (unit -> lambda * 'a) -> lambda * 'a
-val transl_store_label_init:
-    Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda
-
-val method_ids: Ident.Set.t ref (* reset when starting a new wrapper *)
-
-val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda
-val oo_add_class: Ident.t -> Env.t * bool
-
-val reset: unit -> unit
diff --git a/bytecomp/translprim.ml b/bytecomp/translprim.ml
deleted file mode 100644
index d56002b70c..0000000000
--- a/bytecomp/translprim.ml
+++ /dev/null
@@ -1,811 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 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.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Translation of primitives *)
-
-open Misc
-open Asttypes
-open Primitive
-open Types
-open Typedtree
-open Typeopt
-open Lambda
-
-type error =
-  | Unknown_builtin_primitive of string
-  | Wrong_arity_builtin_primitive of string
-
-exception Error of Location.t * error
-
-(* Insertion of debugging events *)
-
-let event_before exp lam = match lam with
-| Lstaticraise (_,_) -> lam
-| _ ->
-  if !Clflags.debug && not !Clflags.native_code
-  then Levent(lam, {lev_loc = exp.exp_loc;
-                    lev_kind = Lev_before;
-                    lev_repr = None;
-                    lev_env = exp.exp_env})
-  else lam
-
-let event_after exp lam =
-  if !Clflags.debug && not !Clflags.native_code
-  then Levent(lam, {lev_loc = exp.exp_loc;
-                    lev_kind = Lev_after exp.exp_type;
-                    lev_repr = None;
-                    lev_env = exp.exp_env})
-  else lam
-
-type comparison =
-  | Equal
-  | Not_equal
-  | Less_equal
-  | Less_than
-  | Greater_equal
-  | Greater_than
-  | Compare
-
-type comparison_kind =
-  | Compare_generic
-  | Compare_ints
-  | Compare_floats
-  | Compare_strings
-  | Compare_bytes
-  | Compare_nativeints
-  | Compare_int32s
-  | Compare_int64s
-
-type loc_kind =
-  | Loc_FILE
-  | Loc_LINE
-  | Loc_MODULE
-  | Loc_LOC
-  | Loc_POS
-
-type prim =
-  | Primitive of Lambda.primitive * int
-  | External of Primitive.description
-  | Comparison of comparison * comparison_kind
-  | Raise of Lambda.raise_kind
-  | Raise_with_backtrace
-  | Lazy_force
-  | Loc of loc_kind
-  | Send
-  | Send_self
-  | Send_cache
-
-let used_primitives = Hashtbl.create 7
-let add_used_primitive loc env path =
-  match path with
-    Some (Path.Pdot _ as path) ->
-      let path = Env.normalize_path_prefix (Some loc) env path in
-      let unit = Path.head path in
-      if Ident.global unit && not (Hashtbl.mem used_primitives path)
-      then Hashtbl.add used_primitives path loc
-  | _ -> ()
-
-let clear_used_primitives () = Hashtbl.clear used_primitives
-let get_used_primitives () =
-  Hashtbl.fold (fun path _ acc -> path :: acc) used_primitives []
-
-let gen_array_kind =
-  if Config.flat_float_array then Pgenarray else Paddrarray
-
-let prim_sys_argv =
-  Primitive.simple ~name:"caml_sys_argv" ~arity:1 ~alloc:true
-
-let primitives_table =
-  create_hashtable 57 [
-    "%identity", Primitive (Pidentity, 1);
-    "%bytes_to_string", Primitive (Pbytes_to_string, 1);
-    "%bytes_of_string", Primitive (Pbytes_of_string, 1);
-    "%ignore", Primitive (Pignore, 1);
-    "%revapply", Primitive (Prevapply, 2);
-    "%apply", Primitive (Pdirapply, 2);
-    "%loc_LOC", Loc Loc_LOC;
-    "%loc_FILE", Loc Loc_FILE;
-    "%loc_LINE", Loc Loc_LINE;
-    "%loc_POS", Loc Loc_POS;
-    "%loc_MODULE", Loc Loc_MODULE;
-    "%field0", Primitive ((Pfield 0), 1);
-    "%field1", Primitive ((Pfield 1), 1);
-    "%setfield0", Primitive ((Psetfield(0, Pointer, Assignment)), 2);
-    "%makeblock", Primitive ((Pmakeblock(0, Immutable, None)), 1);
-    "%makemutable", Primitive ((Pmakeblock(0, Mutable, None)), 1);
-    "%raise", Raise Raise_regular;
-    "%reraise", Raise Raise_reraise;
-    "%raise_notrace", Raise Raise_notrace;
-    "%raise_with_backtrace", Raise_with_backtrace;
-    "%sequand", Primitive (Psequand, 2);
-    "%sequor", Primitive (Psequor, 2);
-    "%boolnot", Primitive (Pnot, 1);
-    "%big_endian", Primitive ((Pctconst Big_endian), 1);
-    "%backend_type", Primitive ((Pctconst Backend_type), 1);
-    "%word_size", Primitive ((Pctconst Word_size), 1);
-    "%int_size", Primitive ((Pctconst Int_size), 1);
-    "%max_wosize", Primitive ((Pctconst Max_wosize), 1);
-    "%ostype_unix", Primitive ((Pctconst Ostype_unix), 1);
-    "%ostype_win32", Primitive ((Pctconst Ostype_win32), 1);
-    "%ostype_cygwin", Primitive ((Pctconst Ostype_cygwin), 1);
-    "%negint", Primitive (Pnegint, 1);
-    "%succint", Primitive ((Poffsetint 1), 1);
-    "%predint", Primitive ((Poffsetint(-1)), 1);
-    "%addint", Primitive (Paddint, 2);
-    "%subint", Primitive (Psubint, 2);
-    "%mulint", Primitive (Pmulint, 2);
-    "%divint", Primitive ((Pdivint Safe), 2);
-    "%modint", Primitive ((Pmodint Safe), 2);
-    "%andint", Primitive (Pandint, 2);
-    "%orint", Primitive (Porint, 2);
-    "%xorint", Primitive (Pxorint, 2);
-    "%lslint", Primitive (Plslint, 2);
-    "%lsrint", Primitive (Plsrint, 2);
-    "%asrint", Primitive (Pasrint, 2);
-    "%eq", Primitive ((Pintcomp Ceq), 2);
-    "%noteq", Primitive ((Pintcomp Cne), 2);
-    "%ltint", Primitive ((Pintcomp Clt), 2);
-    "%leint", Primitive ((Pintcomp Cle), 2);
-    "%gtint", Primitive ((Pintcomp Cgt), 2);
-    "%geint", Primitive ((Pintcomp Cge), 2);
-    "%incr", Primitive ((Poffsetref(1)), 1);
-    "%decr", Primitive ((Poffsetref(-1)), 1);
-    "%intoffloat", Primitive (Pintoffloat, 1);
-    "%floatofint", Primitive (Pfloatofint, 1);
-    "%negfloat", Primitive (Pnegfloat, 1);
-    "%absfloat", Primitive (Pabsfloat, 1);
-    "%addfloat", Primitive (Paddfloat, 2);
-    "%subfloat", Primitive (Psubfloat, 2);
-    "%mulfloat", Primitive (Pmulfloat, 2);
-    "%divfloat", Primitive (Pdivfloat, 2);
-    "%eqfloat", Primitive ((Pfloatcomp CFeq), 2);
-    "%noteqfloat", Primitive ((Pfloatcomp CFneq), 2);
-    "%ltfloat", Primitive ((Pfloatcomp CFlt), 2);
-    "%lefloat", Primitive ((Pfloatcomp CFle), 2);
-    "%gtfloat", Primitive ((Pfloatcomp CFgt), 2);
-    "%gefloat", Primitive ((Pfloatcomp CFge), 2);
-    "%string_length", Primitive (Pstringlength, 1);
-    "%string_safe_get", Primitive (Pstringrefs, 2);
-    "%string_safe_set", Primitive (Pbytessets, 3);
-    "%string_unsafe_get", Primitive (Pstringrefu, 2);
-    "%string_unsafe_set", Primitive (Pbytessetu, 3);
-    "%bytes_length", Primitive (Pbyteslength, 1);
-    "%bytes_safe_get", Primitive (Pbytesrefs, 2);
-    "%bytes_safe_set", Primitive (Pbytessets, 3);
-    "%bytes_unsafe_get", Primitive (Pbytesrefu, 2);
-    "%bytes_unsafe_set", Primitive (Pbytessetu, 3);
-    "%array_length", Primitive ((Parraylength gen_array_kind), 1);
-    "%array_safe_get", Primitive ((Parrayrefs gen_array_kind), 2);
-    "%array_safe_set", Primitive ((Parraysets gen_array_kind), 3);
-    "%array_unsafe_get", Primitive ((Parrayrefu gen_array_kind), 2);
-    "%array_unsafe_set", Primitive ((Parraysetu gen_array_kind), 3);
-    "%obj_size", Primitive ((Parraylength gen_array_kind), 1);
-    "%obj_field", Primitive ((Parrayrefu gen_array_kind), 2);
-    "%obj_set_field", Primitive ((Parraysetu gen_array_kind), 3);
-    "%floatarray_length", Primitive ((Parraylength Pfloatarray), 1);
-    "%floatarray_safe_get", Primitive ((Parrayrefs Pfloatarray), 2);
-    "%floatarray_safe_set", Primitive ((Parraysets Pfloatarray), 3);
-    "%floatarray_unsafe_get", Primitive ((Parrayrefu Pfloatarray), 2);
-    "%floatarray_unsafe_set", Primitive ((Parraysetu Pfloatarray), 3);
-    "%obj_is_int", Primitive (Pisint, 1);
-    "%lazy_force", Lazy_force;
-    "%nativeint_of_int", Primitive ((Pbintofint Pnativeint), 1);
-    "%nativeint_to_int", Primitive ((Pintofbint Pnativeint), 1);
-    "%nativeint_neg", Primitive ((Pnegbint Pnativeint), 1);
-    "%nativeint_add", Primitive ((Paddbint Pnativeint), 2);
-    "%nativeint_sub", Primitive ((Psubbint Pnativeint), 2);
-    "%nativeint_mul", Primitive ((Pmulbint Pnativeint), 2);
-    "%nativeint_div",
-    Primitive ((Pdivbint { size = Pnativeint; is_safe = Safe }), 2);
-    "%nativeint_mod",
-    Primitive ((Pmodbint { size = Pnativeint; is_safe = Safe }), 2);
-    "%nativeint_and", Primitive ((Pandbint Pnativeint), 2);
-    "%nativeint_or", Primitive ( (Porbint Pnativeint), 2);
-    "%nativeint_xor", Primitive ((Pxorbint Pnativeint), 2);
-    "%nativeint_lsl", Primitive ((Plslbint Pnativeint), 2);
-    "%nativeint_lsr", Primitive ((Plsrbint Pnativeint), 2);
-    "%nativeint_asr", Primitive ((Pasrbint Pnativeint), 2);
-    "%int32_of_int", Primitive ((Pbintofint Pint32), 1);
-    "%int32_to_int", Primitive ((Pintofbint Pint32), 1);
-    "%int32_neg", Primitive ((Pnegbint Pint32), 1);
-    "%int32_add", Primitive ((Paddbint Pint32), 2);
-    "%int32_sub", Primitive ((Psubbint Pint32), 2);
-    "%int32_mul", Primitive ((Pmulbint Pint32), 2);
-    "%int32_div", Primitive ((Pdivbint { size = Pint32; is_safe = Safe }), 2);
-    "%int32_mod", Primitive ((Pmodbint { size = Pint32; is_safe = Safe }), 2);
-    "%int32_and", Primitive ((Pandbint Pint32), 2);
-    "%int32_or", Primitive ( (Porbint Pint32), 2);
-    "%int32_xor", Primitive ((Pxorbint Pint32), 2);
-    "%int32_lsl", Primitive ((Plslbint Pint32), 2);
-    "%int32_lsr", Primitive ((Plsrbint Pint32), 2);
-    "%int32_asr", Primitive ((Pasrbint Pint32), 2);
-    "%int64_of_int", Primitive ((Pbintofint Pint64), 1);
-    "%int64_to_int", Primitive ((Pintofbint Pint64), 1);
-    "%int64_neg", Primitive ((Pnegbint Pint64), 1);
-    "%int64_add", Primitive ((Paddbint Pint64), 2);
-    "%int64_sub", Primitive ((Psubbint Pint64), 2);
-    "%int64_mul", Primitive ((Pmulbint Pint64), 2);
-    "%int64_div", Primitive ((Pdivbint { size = Pint64; is_safe = Safe }), 2);
-    "%int64_mod", Primitive ((Pmodbint { size = Pint64; is_safe = Safe }), 2);
-    "%int64_and", Primitive ((Pandbint Pint64), 2);
-    "%int64_or", Primitive ( (Porbint Pint64), 2);
-    "%int64_xor", Primitive ((Pxorbint Pint64), 2);
-    "%int64_lsl", Primitive ((Plslbint Pint64), 2);
-    "%int64_lsr", Primitive ((Plsrbint Pint64), 2);
-    "%int64_asr", Primitive ((Pasrbint Pint64), 2);
-    "%nativeint_of_int32", Primitive ((Pcvtbint(Pint32, Pnativeint)), 1);
-    "%nativeint_to_int32", Primitive ((Pcvtbint(Pnativeint, Pint32)), 1);
-    "%int64_of_int32", Primitive ((Pcvtbint(Pint32, Pint64)), 1);
-    "%int64_to_int32", Primitive ((Pcvtbint(Pint64, Pint32)), 1);
-    "%int64_of_nativeint", Primitive ((Pcvtbint(Pnativeint, Pint64)), 1);
-    "%int64_to_nativeint", Primitive ((Pcvtbint(Pint64, Pnativeint)), 1);
-    "%caml_ba_ref_1",
-    Primitive
-      ((Pbigarrayref(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)),
-       2);
-    "%caml_ba_ref_2",
-    Primitive
-      ((Pbigarrayref(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)),
-       3);
-    "%caml_ba_ref_3",
-    Primitive
-      ((Pbigarrayref(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)),
-       4);
-    "%caml_ba_set_1",
-    Primitive
-      ((Pbigarrayset(false, 1, Pbigarray_unknown, Pbigarray_unknown_layout)),
-       3);
-    "%caml_ba_set_2",
-    Primitive
-      ((Pbigarrayset(false, 2, Pbigarray_unknown, Pbigarray_unknown_layout)),
-       4);
-    "%caml_ba_set_3",
-    Primitive
-      ((Pbigarrayset(false, 3, Pbigarray_unknown, Pbigarray_unknown_layout)),
-       5);
-    "%caml_ba_unsafe_ref_1",
-    Primitive
-      ((Pbigarrayref(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)),
-       2);
-    "%caml_ba_unsafe_ref_2",
-    Primitive
-      ((Pbigarrayref(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)),
-       3);
-    "%caml_ba_unsafe_ref_3",
-    Primitive
-      ((Pbigarrayref(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)),
-       4);
-    "%caml_ba_unsafe_set_1",
-    Primitive
-      ((Pbigarrayset(true, 1, Pbigarray_unknown, Pbigarray_unknown_layout)),
-       3);
-    "%caml_ba_unsafe_set_2",
-    Primitive
-      ((Pbigarrayset(true, 2, Pbigarray_unknown, Pbigarray_unknown_layout)),
-       4);
-    "%caml_ba_unsafe_set_3",
-    Primitive
-      ((Pbigarrayset(true, 3, Pbigarray_unknown, Pbigarray_unknown_layout)),
-       5);
-    "%caml_ba_dim_1", Primitive ((Pbigarraydim(1)), 1);
-    "%caml_ba_dim_2", Primitive ((Pbigarraydim(2)), 1);
-    "%caml_ba_dim_3", Primitive ((Pbigarraydim(3)), 1);
-    "%caml_string_get16", Primitive ((Pstring_load_16(false)), 2);
-    "%caml_string_get16u", Primitive ((Pstring_load_16(true)), 2);
-    "%caml_string_get32", Primitive ((Pstring_load_32(false)), 2);
-    "%caml_string_get32u", Primitive ((Pstring_load_32(true)), 2);
-    "%caml_string_get64", Primitive ((Pstring_load_64(false)), 2);
-    "%caml_string_get64u", Primitive ((Pstring_load_64(true)), 2);
-    "%caml_string_set16", Primitive ((Pbytes_set_16(false)), 3);
-    "%caml_string_set16u", Primitive ((Pbytes_set_16(true)), 3);
-    "%caml_string_set32", Primitive ((Pbytes_set_32(false)), 3);
-    "%caml_string_set32u", Primitive ((Pbytes_set_32(true)), 3);
-    "%caml_string_set64", Primitive ((Pbytes_set_64(false)), 3);
-    "%caml_string_set64u", Primitive ((Pbytes_set_64(true)), 3);
-    "%caml_bytes_get16", Primitive ((Pbytes_load_16(false)), 2);
-    "%caml_bytes_get16u", Primitive ((Pbytes_load_16(true)), 2);
-    "%caml_bytes_get32", Primitive ((Pbytes_load_32(false)), 2);
-    "%caml_bytes_get32u", Primitive ((Pbytes_load_32(true)), 2);
-    "%caml_bytes_get64", Primitive ((Pbytes_load_64(false)), 2);
-    "%caml_bytes_get64u", Primitive ((Pbytes_load_64(true)), 2);
-    "%caml_bytes_set16", Primitive ((Pbytes_set_16(false)), 3);
-    "%caml_bytes_set16u", Primitive ((Pbytes_set_16(true)), 3);
-    "%caml_bytes_set32", Primitive ((Pbytes_set_32(false)), 3);
-    "%caml_bytes_set32u", Primitive ((Pbytes_set_32(true)), 3);
-    "%caml_bytes_set64", Primitive ((Pbytes_set_64(false)), 3);
-    "%caml_bytes_set64u", Primitive ((Pbytes_set_64(true)), 3);
-    "%caml_bigstring_get16", Primitive ((Pbigstring_load_16(false)), 2);
-    "%caml_bigstring_get16u", Primitive ((Pbigstring_load_16(true)), 2);
-    "%caml_bigstring_get32", Primitive ((Pbigstring_load_32(false)), 2);
-    "%caml_bigstring_get32u", Primitive ((Pbigstring_load_32(true)), 2);
-    "%caml_bigstring_get64", Primitive ((Pbigstring_load_64(false)), 2);
-    "%caml_bigstring_get64u", Primitive ((Pbigstring_load_64(true)), 2);
-    "%caml_bigstring_set16", Primitive ((Pbigstring_set_16(false)), 3);
-    "%caml_bigstring_set16u", Primitive ((Pbigstring_set_16(true)), 3);
-    "%caml_bigstring_set32", Primitive ((Pbigstring_set_32(false)), 3);
-    "%caml_bigstring_set32u", Primitive ((Pbigstring_set_32(true)), 3);
-    "%caml_bigstring_set64", Primitive ((Pbigstring_set_64(false)), 3);
-    "%caml_bigstring_set64u", Primitive ((Pbigstring_set_64(true)), 3);
-    "%bswap16", Primitive (Pbswap16, 1);
-    "%bswap_int32", Primitive ((Pbbswap(Pint32)), 1);
-    "%bswap_int64", Primitive ((Pbbswap(Pint64)), 1);
-    "%bswap_native", Primitive ((Pbbswap(Pnativeint)), 1);
-    "%int_as_pointer", Primitive (Pint_as_pointer, 1);
-    "%opaque", Primitive (Popaque, 1);
-    "%sys_argv", External prim_sys_argv;
-    "%send", Send;
-    "%sendself", Send_self;
-    "%sendcache", Send_cache;
-    "%equal", Comparison(Equal, Compare_generic);
-    "%notequal", Comparison(Not_equal, Compare_generic);
-    "%lessequal", Comparison(Less_equal, Compare_generic);
-    "%lessthan", Comparison(Less_than, Compare_generic);
-    "%greaterequal", Comparison(Greater_equal, Compare_generic);
-    "%greaterthan", Comparison(Greater_than, Compare_generic);
-    "%compare", Comparison(Compare, Compare_generic);
-  ]
-
-
-let lookup_primitive loc p =
-  match Hashtbl.find primitives_table p.prim_name with
-  | prim -> prim
-  | exception Not_found ->
-      if String.length p.prim_name > 0 && p.prim_name.[0] = '%' then
-        raise(Error(loc, Unknown_builtin_primitive p.prim_name));
-      External p
-
-let lookup_primitive_and_mark_used loc p env path =
-  match lookup_primitive loc p with
-  | External _ as e -> add_used_primitive loc env path; e
-  | x -> x
-
-let simplify_constant_constructor = function
-  | Equal -> true
-  | Not_equal -> true
-  | Less_equal -> false
-  | Less_than -> false
-  | Greater_equal -> false
-  | Greater_than -> false
-  | Compare -> false
-
-(* The following function computes the greatest lower bound in the
-   semilattice of array kinds:
-          gen
-         /   \
-      addr   float
-       |
-      int
-   Note that the GLB is not guaranteed to exist, in which case we return
-   our first argument instead of raising a fatal error because, although
-   it cannot happen in a well-typed program, (ab)use of Obj.magic can
-   probably trigger it.
-*)
-let glb_array_type t1 t2 =
-  match t1, t2 with
-  | Pfloatarray, (Paddrarray | Pintarray)
-  | (Paddrarray | Pintarray), Pfloatarray -> t1
-
-  | Pgenarray, x | x, Pgenarray -> x
-  | Paddrarray, x | x, Paddrarray -> x
-  | Pintarray, Pintarray -> Pintarray
-  | Pfloatarray, Pfloatarray -> Pfloatarray
-
-(* Specialize a primitive from available type information. *)
-
-let specialize_primitive env ty ~has_constant_constructor prim =
-  let param_tys =
-    match is_function_type env ty with
-    | None -> []
-    | Some (p1, rhs) ->
-      match is_function_type env rhs with
-      | None -> [p1]
-      | Some (p2, _) -> [p1;p2]
-  in
-  match prim, param_tys with
-  | Primitive (Psetfield(n, Pointer, init), arity), [_; p2] -> begin
-      match maybe_pointer_type env p2 with
-      | Pointer -> None
-      | Immediate -> Some (Primitive (Psetfield(n, Immediate, init), arity))
-    end
-  | Primitive (Parraylength t, arity), [p] -> begin
-      let array_type = glb_array_type t (array_type_kind env p) in
-      if t = array_type then None
-      else Some (Primitive (Parraylength array_type, arity))
-    end
-  | Primitive (Parrayrefu t, arity), p1 :: _ -> begin
-      let array_type = glb_array_type t (array_type_kind env p1) in
-      if t = array_type then None
-      else Some (Primitive (Parrayrefu array_type, arity))
-    end
-  | Primitive (Parraysetu t, arity), p1 :: _ -> begin
-      let array_type = glb_array_type t (array_type_kind env p1) in
-      if t = array_type then None
-      else Some (Primitive (Parraysetu array_type, arity))
-    end
-  | Primitive (Parrayrefs t, arity), p1 :: _ -> begin
-      let array_type = glb_array_type t (array_type_kind env p1) in
-      if t = array_type then None
-      else Some (Primitive (Parrayrefs array_type, arity))
-    end
-  | Primitive (Parraysets t, arity), p1 :: _ -> begin
-      let array_type = glb_array_type t (array_type_kind env p1) in
-      if t = array_type then None
-      else Some (Primitive (Parraysets array_type, arity))
-    end
-  | Primitive (Pbigarrayref(unsafe, n, Pbigarray_unknown,
-                            Pbigarray_unknown_layout), arity), p1 :: _ -> begin
-      let (k, l) = bigarray_type_kind_and_layout env p1 in
-      match k, l with
-      | Pbigarray_unknown, Pbigarray_unknown_layout -> None
-      | _, _ -> Some (Primitive (Pbigarrayref(unsafe, n, k, l), arity))
-    end
-  | Primitive (Pbigarrayset(unsafe, n, Pbigarray_unknown,
-                            Pbigarray_unknown_layout), arity), p1 :: _ -> begin
-      let (k, l) = bigarray_type_kind_and_layout env p1 in
-      match k, l with
-      | Pbigarray_unknown, Pbigarray_unknown_layout -> None
-      | _, _ -> Some (Primitive (Pbigarrayset(unsafe, n, k, l), arity))
-    end
-  | Primitive (Pmakeblock(tag, mut, None), arity), fields -> begin
-      let shape = List.map (Typeopt.value_kind env) fields in
-      let useful = List.exists (fun knd -> knd <> Pgenval) shape in
-      if useful then Some (Primitive (Pmakeblock(tag, mut, Some shape), arity))
-      else None
-    end
-  | Comparison(comp, Compare_generic), p1 :: _ ->
-    if (has_constant_constructor
-        && simplify_constant_constructor comp) then begin
-      Some (Comparison(comp, Compare_ints))
-    end else if (is_base_type env p1 Predef.path_int
-        || is_base_type env p1 Predef.path_char
-        || (maybe_pointer_type env p1 = Immediate)) then begin
-      Some (Comparison(comp, Compare_ints))
-    end else if is_base_type env p1 Predef.path_float then begin
-      Some (Comparison(comp, Compare_floats))
-    end else if is_base_type env p1 Predef.path_string then begin
-      Some (Comparison(comp, Compare_strings))
-    end else if is_base_type env p1 Predef.path_bytes then begin
-      Some (Comparison(comp, Compare_bytes))
-    end else if is_base_type env p1 Predef.path_nativeint then begin
-      Some (Comparison(comp, Compare_nativeints))
-    end else if is_base_type env p1 Predef.path_int32 then begin
-      Some (Comparison(comp, Compare_int32s))
-    end else if is_base_type env p1 Predef.path_int64 then begin
-      Some (Comparison(comp, Compare_int64s))
-    end else begin
-      None
-    end
-  | _ -> None
-
-let unboxed_compare name native_repr =
-  Primitive.make ~name ~alloc:false ~native_name:(name^"_unboxed")
-    ~native_repr_args:[native_repr;native_repr] ~native_repr_res:Untagged_int
-
-let caml_equal =
-  Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true
-let caml_string_equal =
-  Primitive.simple ~name:"caml_string_equal" ~arity:2 ~alloc:false
-let caml_bytes_equal =
-  Primitive.simple ~name:"caml_bytes_equal" ~arity:2 ~alloc:false
-let caml_notequal =
-  Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true
-let caml_string_notequal =
-  Primitive.simple ~name:"caml_string_notequal" ~arity:2 ~alloc:false
-let caml_bytes_notequal =
-  Primitive.simple ~name:"caml_bytes_notequal" ~arity:2 ~alloc:false
-let caml_lessequal =
-  Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true
-let caml_string_lessequal =
-  Primitive.simple ~name:"caml_string_lessequal" ~arity:2 ~alloc:false
-let caml_bytes_lessequal =
-  Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2 ~alloc:false
-let caml_lessthan =
-  Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true
-let caml_string_lessthan =
-  Primitive.simple ~name:"caml_string_lessthan" ~arity:2 ~alloc:false
-let caml_bytes_lessthan =
-  Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2 ~alloc:false
-let caml_greaterequal =
-  Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true
-let caml_string_greaterequal =
-  Primitive.simple ~name:"caml_string_greaterequal" ~arity:2 ~alloc:false
-let caml_bytes_greaterequal =
-  Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2 ~alloc:false
-let caml_greaterthan =
-  Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true
-let caml_string_greaterthan =
-  Primitive.simple ~name:"caml_string_greaterthan" ~arity:2 ~alloc: false
-let caml_bytes_greaterthan =
-  Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2 ~alloc: false
-let caml_compare =
-  Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true
-let caml_int_compare =
-  (* Not unboxed since the comparison is done directly on tagged int *)
-  Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false
-let caml_float_compare =
-  unboxed_compare "caml_float_compare" Unboxed_float
-let caml_string_compare =
-  Primitive.simple ~name:"caml_string_compare" ~arity:2 ~alloc:false
-let caml_bytes_compare =
-  Primitive.simple ~name:"caml_bytes_compare" ~arity:2 ~alloc:false
-let caml_nativeint_compare =
-  unboxed_compare "caml_nativeint_compare" (Unboxed_integer Pnativeint)
-let caml_int32_compare =
-  unboxed_compare "caml_int32_compare" (Unboxed_integer Pint32)
-let caml_int64_compare =
-  unboxed_compare "caml_int64_compare" (Unboxed_integer Pint64)
-
-let comparison_primitive comparison comparison_kind =
-  match comparison, comparison_kind with
-  | Equal, Compare_generic -> Pccall caml_equal
-  | Equal, Compare_ints -> Pintcomp Ceq
-  | Equal, Compare_floats -> Pfloatcomp CFeq
-  | Equal, Compare_strings -> Pccall caml_string_equal
-  | Equal, Compare_bytes -> Pccall caml_bytes_equal
-  | Equal, Compare_nativeints -> Pbintcomp(Pnativeint, Ceq)
-  | Equal, Compare_int32s -> Pbintcomp(Pint32, Ceq)
-  | Equal, Compare_int64s -> Pbintcomp(Pint64, Ceq)
-  | Not_equal, Compare_generic -> Pccall caml_notequal
-  | Not_equal, Compare_ints -> Pintcomp Cne
-  | Not_equal, Compare_floats -> Pfloatcomp CFneq
-  | Not_equal, Compare_strings -> Pccall caml_string_notequal
-  | Not_equal, Compare_bytes -> Pccall caml_bytes_notequal
-  | Not_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cne)
-  | Not_equal, Compare_int32s -> Pbintcomp(Pint32, Cne)
-  | Not_equal, Compare_int64s -> Pbintcomp(Pint64, Cne)
-  | Less_equal, Compare_generic -> Pccall caml_lessequal
-  | Less_equal, Compare_ints -> Pintcomp Cle
-  | Less_equal, Compare_floats -> Pfloatcomp CFle
-  | Less_equal, Compare_strings -> Pccall caml_string_lessequal
-  | Less_equal, Compare_bytes -> Pccall caml_bytes_lessequal
-  | Less_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cle)
-  | Less_equal, Compare_int32s -> Pbintcomp(Pint32, Cle)
-  | Less_equal, Compare_int64s -> Pbintcomp(Pint64, Cle)
-  | Less_than, Compare_generic -> Pccall caml_lessthan
-  | Less_than, Compare_ints -> Pintcomp Clt
-  | Less_than, Compare_floats -> Pfloatcomp CFlt
-  | Less_than, Compare_strings -> Pccall caml_string_lessthan
-  | Less_than, Compare_bytes -> Pccall caml_bytes_lessthan
-  | Less_than, Compare_nativeints -> Pbintcomp(Pnativeint, Clt)
-  | Less_than, Compare_int32s -> Pbintcomp(Pint32, Clt)
-  | Less_than, Compare_int64s -> Pbintcomp(Pint64, Clt)
-  | Greater_equal, Compare_generic -> Pccall caml_greaterequal
-  | Greater_equal, Compare_ints -> Pintcomp Cge
-  | Greater_equal, Compare_floats -> Pfloatcomp CFge
-  | Greater_equal, Compare_strings -> Pccall caml_string_greaterequal
-  | Greater_equal, Compare_bytes -> Pccall caml_bytes_greaterequal
-  | Greater_equal, Compare_nativeints -> Pbintcomp(Pnativeint, Cge)
-  | Greater_equal, Compare_int32s -> Pbintcomp(Pint32, Cge)
-  | Greater_equal, Compare_int64s -> Pbintcomp(Pint64, Cge)
-  | Greater_than, Compare_generic -> Pccall caml_greaterthan
-  | Greater_than, Compare_ints -> Pintcomp Cgt
-  | Greater_than, Compare_floats -> Pfloatcomp CFgt
-  | Greater_than, Compare_strings -> Pccall caml_string_greaterthan
-  | Greater_than, Compare_bytes -> Pccall caml_bytes_greaterthan
-  | Greater_than, Compare_nativeints -> Pbintcomp(Pnativeint, Cgt)
-  | Greater_than, Compare_int32s -> Pbintcomp(Pint32, Cgt)
-  | Greater_than, Compare_int64s -> Pbintcomp(Pint64, Cgt)
-  | Compare, Compare_generic -> Pccall caml_compare
-  | Compare, Compare_ints -> Pccall caml_int_compare
-  | Compare, Compare_floats -> Pccall caml_float_compare
-  | Compare, Compare_strings -> Pccall caml_string_compare
-  | Compare, Compare_bytes -> Pccall caml_bytes_compare
-  | Compare, Compare_nativeints -> Pccall caml_nativeint_compare
-  | Compare, Compare_int32s -> Pccall caml_int32_compare
-  | Compare, Compare_int64s -> Pccall caml_int64_compare
-
-let lambda_of_loc kind loc =
-  let loc_start = loc.Location.loc_start in
-  let (file, lnum, cnum) = Location.get_pos_info loc_start in
-  let file =
-    if Filename.is_relative file then
-      file
-    else
-      Location.rewrite_absolute_path file in
-  let enum = loc.Location.loc_end.Lexing.pos_cnum -
-      loc_start.Lexing.pos_cnum + cnum in
-  match kind with
-  | Loc_POS ->
-    Lconst (Const_block (0, [
-          Const_immstring file;
-          Const_base (Const_int lnum);
-          Const_base (Const_int cnum);
-          Const_base (Const_int enum);
-        ]))
-  | Loc_FILE -> Lconst (Const_immstring file)
-  | Loc_MODULE ->
-    let filename = Filename.basename file in
-    let name = Env.get_unit_name () in
-    let module_name = if name = "" then "//"^filename^"//" else name in
-    Lconst (Const_immstring module_name)
-  | Loc_LOC ->
-    let loc = Printf.sprintf "File %S, line %d, characters %d-%d"
-        file lnum cnum enum in
-    Lconst (Const_immstring loc)
-  | Loc_LINE -> Lconst (Const_base (Const_int lnum))
-
-let caml_restore_raw_backtrace =
-  Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false
-
-let try_ids = Hashtbl.create 8
-
-let add_exception_ident id =
-  Hashtbl.replace try_ids id ()
-
-let remove_exception_ident id =
-  Hashtbl.remove try_ids id
-
-let lambda_of_prim prim_name prim loc args arg_exps =
-  match prim, args with
-  | Primitive (prim, arity), args when arity = List.length args ->
-      Lprim(prim, args, loc)
-  | External prim, args when prim = prim_sys_argv ->
-      Lprim(Pccall prim, Lconst (Const_pointer 0) :: args, loc)
-  | External prim, args ->
-      Lprim(Pccall prim, args, loc)
-  | Comparison(comp, knd), ([_;_] as args) ->
-      let prim = comparison_primitive comp knd in
-      Lprim(prim, args, loc)
-  | Raise kind, [arg] ->
-      let kind =
-        match kind, arg with
-        | Raise_regular, Lvar argv when Hashtbl.mem try_ids argv ->
-            Raise_reraise
-        | _, _ ->
-            kind
-      in
-      let arg =
-        match arg_exps with
-        | None -> arg
-        | Some [arg_exp] -> event_after arg_exp arg
-        | Some _ -> assert false
-      in
-      Lprim(Praise kind, [arg], loc)
-  | Raise_with_backtrace, [exn; bt] ->
-      let vexn = Ident.create_local "exn" in
-      let raise_arg =
-        match arg_exps with
-        | None -> Lvar vexn
-        | Some [exn_exp; _] -> event_after exn_exp (Lvar vexn)
-        | Some _ -> assert false
-      in
-      Llet(Strict, Pgenval, vexn, exn,
-           Lsequence(Lprim(Pccall caml_restore_raw_backtrace,
-                           [Lvar vexn; bt],
-                           loc),
-                     Lprim(Praise Raise_reraise, [raise_arg], loc)))
-  | Lazy_force, [arg] ->
-      Matching.inline_lazy_force arg Location.none
-  | Loc kind, [] ->
-      lambda_of_loc kind loc
-  | Loc kind, [arg] ->
-      let lam = lambda_of_loc kind loc in
-      Lprim(Pmakeblock(0, Immutable, None), [lam; arg], loc)
-  | Send, [obj; meth] ->
-      Lsend(Public, meth, obj, [], loc)
-  | Send_self, [obj; meth] ->
-      Lsend(Self, meth, obj, [], loc)
-  | Send_cache, [obj; meth; cache; pos] ->
-      Lsend(Cached, meth, obj, [cache; pos], loc)
-  | (Raise _ | Raise_with_backtrace
-    | Lazy_force | Loc _ | Primitive _ | Comparison _
-    | Send | Send_self | Send_cache), _ ->
-      raise(Error(loc, Wrong_arity_builtin_primitive prim_name))
-
-let check_primitive_arity loc p =
-  let prim = lookup_primitive loc p in
-  let ok =
-    match prim with
-    | Primitive (_,arity) -> arity = p.prim_arity
-    | External _ -> true
-    | Comparison _ -> p.prim_arity = 2
-    | Raise _ -> p.prim_arity = 1
-    | Raise_with_backtrace -> p.prim_arity = 2
-    | Lazy_force -> p.prim_arity = 1
-    | Loc _ -> p.prim_arity = 1 || p.prim_arity = 0
-    | Send | Send_self -> p.prim_arity = 2
-    | Send_cache -> p.prim_arity = 4
-  in
-  if not ok then raise(Error(loc, Wrong_arity_builtin_primitive p.prim_name))
-
-(* Eta-expand a primitive *)
-
-let transl_primitive loc p env ty path =
-  let prim = lookup_primitive_and_mark_used loc p env path in
-  let has_constant_constructor = false in
-  let prim =
-    match specialize_primitive env ty ~has_constant_constructor prim with
-    | None -> prim
-    | Some prim -> prim
-  in
-  let rec make_params n =
-    if n <= 0 then []
-    else (Ident.create_local "prim", Pgenval) :: make_params (n-1)
-  in
-  let params = make_params p.prim_arity in
-  let args = List.map (fun (id, _) -> Lvar id) params in
-  let body = lambda_of_prim p.prim_name prim loc args None in
-  match params with
-  | [] -> body
-  | _ ->
-      Lfunction{ kind = Curried;
-                 params;
-                 return = Pgenval;
-                 attr = default_stub_attribute;
-                 loc = loc;
-                 body = body; }
-
-(* Determine if a primitive is a Pccall or will be turned later into
-   a C function call that may raise an exception *)
-let primitive_is_ccall = function
-  | Pccall _ | Pstringrefs  | Pbytesrefs | Pbytessets | Parrayrefs _ |
-    Parraysets _ | Pbigarrayref _ | Pbigarrayset _ | Pduprecord _ | Pdirapply |
-    Prevapply -> true
-  | _ -> false
-
-(* Determine if a primitive should be surrounded by an "after" debug event *)
-let primitive_needs_event_after = function
-  | Primitive (prim,_) -> primitive_is_ccall prim
-  | External _ -> true
-  | Comparison(comp, knd) ->
-      primitive_is_ccall (comparison_primitive comp knd)
-  | Lazy_force | Send | Send_self | Send_cache -> true
-  | Raise _ | Raise_with_backtrace | Loc _ -> false
-
-let transl_primitive_application loc p env ty path exp args arg_exps =
-  let prim = lookup_primitive_and_mark_used loc p env (Some path) in
-  let has_constant_constructor =
-    match arg_exps with
-    | [_; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}]
-    | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _)}; _]
-    | [_; {exp_desc = Texp_variant(_, None)}]
-    | [{exp_desc = Texp_variant(_, None)}; _] -> true
-    | _ -> false
-  in
-  let prim =
-    match specialize_primitive env ty ~has_constant_constructor prim with
-    | None -> prim
-    | Some prim -> prim
-  in
-  let lam = lambda_of_prim p.prim_name prim loc args (Some arg_exps) in
-  let lam =
-    if primitive_needs_event_after prim then begin
-      match exp with
-      | None -> lam
-      | Some exp -> event_after exp lam
-    end else begin
-      lam
-    end
-  in
-  lam
-
-(* Error report *)
-
-open Format
-
-let report_error ppf = function
-  | Unknown_builtin_primitive prim_name ->
-      fprintf ppf "Unknown builtin primitive \"%s\"" prim_name
-  | Wrong_arity_builtin_primitive prim_name ->
-      fprintf ppf "Wrong arity for builtin primitive \"%s\"" prim_name
-
-let () =
-  Location.register_error_of_exn
-    (function
-      | Error (loc, err) ->
-          Some (Location.error_of_printer ~loc report_error err)
-      | _ ->
-        None
-    )
diff --git a/bytecomp/translprim.mli b/bytecomp/translprim.mli
deleted file mode 100644
index abf0f7d589..0000000000
--- a/bytecomp/translprim.mli
+++ /dev/null
@@ -1,51 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*                                 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.          *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Insertion of debugging events *)
-
-val event_before : Typedtree.expression -> Lambda.lambda -> Lambda.lambda
-
-val event_after : Typedtree.expression -> Lambda.lambda -> Lambda.lambda
-
-(* Translation of primitives *)
-
-val add_exception_ident : Ident.t -> unit
-val remove_exception_ident : Ident.t -> unit
-
-val clear_used_primitives : unit -> unit
-val get_used_primitives: unit -> Path.t list
-
-val check_primitive_arity : Location.t -> Primitive.description -> unit
-
-val transl_primitive :
-  Location.t -> Primitive.description -> Env.t ->
-  Types.type_expr -> Path.t option -> Lambda.lambda
-
-val transl_primitive_application :
-  Location.t -> Primitive.description -> Env.t ->
-  Types.type_expr -> Path.t -> Typedtree.expression option ->
-  Lambda.lambda list -> Typedtree.expression list -> Lambda.lambda
-
-(* Errors *)
-
-type error =
-  | Unknown_builtin_primitive of string
-  | Wrong_arity_builtin_primitive of string
-
-exception Error of Location.t * error
-
-open Format
-
-val report_error : formatter -> error -> unit